1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Casing
; use Casing
;
30 with Debug
; use Debug
;
31 with Errout
; use Errout
;
32 with Elists
; use Elists
;
33 with Exp_Util
; use Exp_Util
;
34 with Freeze
; use Freeze
;
36 with Lib
.Xref
; use Lib
.Xref
;
37 with Namet
; use Namet
;
38 with Nlists
; use Nlists
;
39 with Nmake
; use Nmake
;
40 with Output
; use Output
;
42 with Restrict
; use Restrict
;
43 with Scans
; use Scans
;
46 with Sem_Ch8
; use Sem_Ch8
;
47 with Sem_Eval
; use Sem_Eval
;
48 with Sem_Res
; use Sem_Res
;
49 with Sem_Type
; use Sem_Type
;
50 with Sinfo
; use Sinfo
;
51 with Sinput
; use Sinput
;
52 with Snames
; use Snames
;
53 with Stand
; use Stand
;
55 with Stringt
; use Stringt
;
56 with Targparm
; use Targparm
;
57 with Tbuild
; use Tbuild
;
58 with Ttypes
; use Ttypes
;
60 package body Sem_Util
is
62 -----------------------
63 -- Local Subprograms --
64 -----------------------
66 function Build_Component_Subtype
71 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
72 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
73 -- Loc is the source location, T is the original subtype.
75 --------------------------------
76 -- Add_Access_Type_To_Process --
77 --------------------------------
79 procedure Add_Access_Type_To_Process
(E
: Entity_Id
; A
: Entity_Id
)
83 Ensure_Freeze_Node
(E
);
84 L
:= Access_Types_To_Process
(Freeze_Node
(E
));
88 Set_Access_Types_To_Process
(Freeze_Node
(E
), L
);
92 end Add_Access_Type_To_Process
;
94 -----------------------
95 -- Alignment_In_Bits --
96 -----------------------
98 function Alignment_In_Bits
(E
: Entity_Id
) return Uint
is
100 return Alignment
(E
) * System_Storage_Unit
;
101 end Alignment_In_Bits
;
103 -----------------------------------------
104 -- Apply_Compile_Time_Constraint_Error --
105 -----------------------------------------
107 procedure Apply_Compile_Time_Constraint_Error
110 Reason
: RT_Exception_Code
;
111 Ent
: Entity_Id
:= Empty
;
112 Typ
: Entity_Id
:= Empty
;
113 Loc
: Source_Ptr
:= No_Location
;
114 Rep
: Boolean := True)
116 Stat
: constant Boolean := Is_Static_Expression
(N
);
126 if No
(Compile_Time_Constraint_Error
(N
, Msg
, Ent
, Loc
))
132 -- Now we replace the node by an N_Raise_Constraint_Error node
133 -- This does not need reanalyzing, so set it as analyzed now.
136 Make_Raise_Constraint_Error
(Sloc
(N
),
138 Set_Analyzed
(N
, True);
140 Set_Raises_Constraint_Error
(N
);
142 -- If the original expression was marked as static, the result is
143 -- still marked as static, but the Raises_Constraint_Error flag is
144 -- always set so that further static evaluation is not attempted.
147 Set_Is_Static_Expression
(N
);
149 end Apply_Compile_Time_Constraint_Error
;
151 --------------------------
152 -- Build_Actual_Subtype --
153 --------------------------
155 function Build_Actual_Subtype
157 N
: Node_Or_Entity_Id
)
162 Loc
: constant Source_Ptr
:= Sloc
(N
);
163 Constraints
: List_Id
;
169 Disc_Type
: Entity_Id
;
172 if Nkind
(N
) = N_Defining_Identifier
then
173 Obj
:= New_Reference_To
(N
, Loc
);
178 if Is_Array_Type
(T
) then
179 Constraints
:= New_List
;
181 for J
in 1 .. Number_Dimensions
(T
) loop
183 -- Build an array subtype declaration with the nominal
184 -- subtype and the bounds of the actual. Add the declaration
185 -- in front of the local declarations for the subprogram,for
186 -- analysis before any reference to the formal in the body.
189 Make_Attribute_Reference
(Loc
,
191 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
192 Attribute_Name
=> Name_First
,
193 Expressions
=> New_List
(
194 Make_Integer_Literal
(Loc
, J
)));
197 Make_Attribute_Reference
(Loc
,
199 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
200 Attribute_Name
=> Name_Last
,
201 Expressions
=> New_List
(
202 Make_Integer_Literal
(Loc
, J
)));
204 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
207 -- If the type has unknown discriminants there is no constrained
210 elsif Has_Unknown_Discriminants
(T
) then
214 Constraints
:= New_List
;
216 if Is_Private_Type
(T
) and then No
(Full_View
(T
)) then
218 -- Type is a generic derived type. Inherit discriminants from
221 Disc_Type
:= Etype
(Base_Type
(T
));
226 Discr
:= First_Discriminant
(Disc_Type
);
228 while Present
(Discr
) loop
229 Append_To
(Constraints
,
230 Make_Selected_Component
(Loc
,
232 Duplicate_Subexpr_No_Checks
(Obj
),
233 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)));
234 Next_Discriminant
(Discr
);
239 Make_Defining_Identifier
(Loc
,
240 Chars
=> New_Internal_Name
('S'));
241 Set_Is_Internal
(Subt
);
244 Make_Subtype_Declaration
(Loc
,
245 Defining_Identifier
=> Subt
,
246 Subtype_Indication
=>
247 Make_Subtype_Indication
(Loc
,
248 Subtype_Mark
=> New_Reference_To
(T
, Loc
),
250 Make_Index_Or_Discriminant_Constraint
(Loc
,
251 Constraints
=> Constraints
)));
253 Mark_Rewrite_Insertion
(Decl
);
255 end Build_Actual_Subtype
;
257 ---------------------------------------
258 -- Build_Actual_Subtype_Of_Component --
259 ---------------------------------------
261 function Build_Actual_Subtype_Of_Component
266 Loc
: constant Source_Ptr
:= Sloc
(N
);
267 P
: constant Node_Id
:= Prefix
(N
);
270 Indx_Type
: Entity_Id
;
272 Deaccessed_T
: Entity_Id
;
273 -- This is either a copy of T, or if T is an access type, then it is
274 -- the directly designated type of this access type.
276 function Build_Actual_Array_Constraint
return List_Id
;
277 -- If one or more of the bounds of the component depends on
278 -- discriminants, build actual constraint using the discriminants
281 function Build_Actual_Record_Constraint
return List_Id
;
282 -- Similar to previous one, for discriminated components constrained
283 -- by the discriminant of the enclosing object.
285 -----------------------------------
286 -- Build_Actual_Array_Constraint --
287 -----------------------------------
289 function Build_Actual_Array_Constraint
return List_Id
is
290 Constraints
: List_Id
:= New_List
;
298 Indx
:= First_Index
(Deaccessed_T
);
299 while Present
(Indx
) loop
300 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
301 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
303 if Denotes_Discriminant
(Old_Lo
) then
305 Make_Selected_Component
(Loc
,
306 Prefix
=> New_Copy_Tree
(P
),
307 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Lo
), Loc
));
310 Lo
:= New_Copy_Tree
(Old_Lo
);
312 -- The new bound will be reanalyzed in the enclosing
313 -- declaration. For literal bounds that come from a type
314 -- declaration, the type of the context must be imposed, so
315 -- insure that analysis will take place. For non-universal
316 -- types this is not strictly necessary.
318 Set_Analyzed
(Lo
, False);
321 if Denotes_Discriminant
(Old_Hi
) then
323 Make_Selected_Component
(Loc
,
324 Prefix
=> New_Copy_Tree
(P
),
325 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Hi
), Loc
));
328 Hi
:= New_Copy_Tree
(Old_Hi
);
329 Set_Analyzed
(Hi
, False);
332 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
337 end Build_Actual_Array_Constraint
;
339 ------------------------------------
340 -- Build_Actual_Record_Constraint --
341 ------------------------------------
343 function Build_Actual_Record_Constraint
return List_Id
is
344 Constraints
: List_Id
:= New_List
;
349 D
:= First_Elmt
(Discriminant_Constraint
(Deaccessed_T
));
350 while Present
(D
) loop
352 if Denotes_Discriminant
(Node
(D
)) then
353 D_Val
:= Make_Selected_Component
(Loc
,
354 Prefix
=> New_Copy_Tree
(P
),
355 Selector_Name
=> New_Occurrence_Of
(Entity
(Node
(D
)), Loc
));
358 D_Val
:= New_Copy_Tree
(Node
(D
));
361 Append
(D_Val
, Constraints
);
366 end Build_Actual_Record_Constraint
;
368 -- Start of processing for Build_Actual_Subtype_Of_Component
371 if Nkind
(N
) = N_Explicit_Dereference
then
372 if Is_Composite_Type
(T
)
373 and then not Is_Constrained
(T
)
374 and then not (Is_Class_Wide_Type
(T
)
375 and then Is_Constrained
(Root_Type
(T
)))
376 and then not Has_Unknown_Discriminants
(T
)
378 -- If the type of the dereference is already constrained, it
379 -- is an actual subtype.
381 if Is_Array_Type
(Etype
(N
))
382 and then Is_Constrained
(Etype
(N
))
386 Remove_Side_Effects
(P
);
387 return Build_Actual_Subtype
(T
, N
);
394 if Ekind
(T
) = E_Access_Subtype
then
395 Deaccessed_T
:= Designated_Type
(T
);
400 if Ekind
(Deaccessed_T
) = E_Array_Subtype
then
402 Id
:= First_Index
(Deaccessed_T
);
403 Indx_Type
:= Underlying_Type
(Etype
(Id
));
405 while Present
(Id
) loop
407 if Denotes_Discriminant
(Type_Low_Bound
(Indx_Type
)) or else
408 Denotes_Discriminant
(Type_High_Bound
(Indx_Type
))
410 Remove_Side_Effects
(P
);
412 Build_Component_Subtype
(
413 Build_Actual_Array_Constraint
, Loc
, Base_Type
(T
));
419 elsif Is_Composite_Type
(Deaccessed_T
)
420 and then Has_Discriminants
(Deaccessed_T
)
421 and then not Has_Unknown_Discriminants
(Deaccessed_T
)
423 D
:= First_Elmt
(Discriminant_Constraint
(Deaccessed_T
));
424 while Present
(D
) loop
426 if Denotes_Discriminant
(Node
(D
)) then
427 Remove_Side_Effects
(P
);
429 Build_Component_Subtype
(
430 Build_Actual_Record_Constraint
, Loc
, Base_Type
(T
));
437 -- If none of the above, the actual and nominal subtypes are the same.
441 end Build_Actual_Subtype_Of_Component
;
443 -----------------------------
444 -- Build_Component_Subtype --
445 -----------------------------
447 function Build_Component_Subtype
458 Make_Defining_Identifier
(Loc
,
459 Chars
=> New_Internal_Name
('S'));
460 Set_Is_Internal
(Subt
);
463 Make_Subtype_Declaration
(Loc
,
464 Defining_Identifier
=> Subt
,
465 Subtype_Indication
=>
466 Make_Subtype_Indication
(Loc
,
467 Subtype_Mark
=> New_Reference_To
(Base_Type
(T
), Loc
),
469 Make_Index_Or_Discriminant_Constraint
(Loc
,
472 Mark_Rewrite_Insertion
(Decl
);
474 end Build_Component_Subtype
;
476 --------------------------------------------
477 -- Build_Discriminal_Subtype_Of_Component --
478 --------------------------------------------
480 function Build_Discriminal_Subtype_Of_Component
484 Loc
: constant Source_Ptr
:= Sloc
(T
);
488 function Build_Discriminal_Array_Constraint
return List_Id
;
489 -- If one or more of the bounds of the component depends on
490 -- discriminants, build actual constraint using the discriminants
493 function Build_Discriminal_Record_Constraint
return List_Id
;
494 -- Similar to previous one, for discriminated components constrained
495 -- by the discriminant of the enclosing object.
497 ----------------------------------------
498 -- Build_Discriminal_Array_Constraint --
499 ----------------------------------------
501 function Build_Discriminal_Array_Constraint
return List_Id
is
502 Constraints
: List_Id
:= New_List
;
510 Indx
:= First_Index
(T
);
511 while Present
(Indx
) loop
512 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
513 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
515 if Denotes_Discriminant
(Old_Lo
) then
516 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
519 Lo
:= New_Copy_Tree
(Old_Lo
);
522 if Denotes_Discriminant
(Old_Hi
) then
523 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
526 Hi
:= New_Copy_Tree
(Old_Hi
);
529 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
534 end Build_Discriminal_Array_Constraint
;
536 -----------------------------------------
537 -- Build_Discriminal_Record_Constraint --
538 -----------------------------------------
540 function Build_Discriminal_Record_Constraint
return List_Id
is
541 Constraints
: List_Id
:= New_List
;
546 D
:= First_Elmt
(Discriminant_Constraint
(T
));
547 while Present
(D
) loop
549 if Denotes_Discriminant
(Node
(D
)) then
551 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
554 D_Val
:= New_Copy_Tree
(Node
(D
));
557 Append
(D_Val
, Constraints
);
562 end Build_Discriminal_Record_Constraint
;
564 -- Start of processing for Build_Discriminal_Subtype_Of_Component
567 if Ekind
(T
) = E_Array_Subtype
then
569 Id
:= First_Index
(T
);
571 while Present
(Id
) loop
573 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
))) or else
574 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
576 return Build_Component_Subtype
577 (Build_Discriminal_Array_Constraint
, Loc
, T
);
583 elsif Ekind
(T
) = E_Record_Subtype
584 and then Has_Discriminants
(T
)
585 and then not Has_Unknown_Discriminants
(T
)
587 D
:= First_Elmt
(Discriminant_Constraint
(T
));
588 while Present
(D
) loop
590 if Denotes_Discriminant
(Node
(D
)) then
591 return Build_Component_Subtype
592 (Build_Discriminal_Record_Constraint
, Loc
, T
);
599 -- If none of the above, the actual and nominal subtypes are the same.
603 end Build_Discriminal_Subtype_Of_Component
;
605 ------------------------------
606 -- Build_Elaboration_Entity --
607 ------------------------------
609 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
610 Loc
: constant Source_Ptr
:= Sloc
(N
);
611 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(Loc
);
614 Elab_Ent
: Entity_Id
;
617 -- Ignore if already constructed
619 if Present
(Elaboration_Entity
(Spec_Id
)) then
623 -- Construct name of elaboration entity as xxx_E, where xxx
624 -- is the unit name with dots replaced by double underscore.
625 -- We have to manually construct this name, since it will
626 -- be elaborated in the outer scope, and thus will not have
627 -- the unit name automatically prepended.
629 Get_Name_String
(Unit_Name
(Unum
));
631 -- Replace the %s by _E
633 Name_Buffer
(Name_Len
- 1 .. Name_Len
) := "_E";
635 -- Replace dots by double underscore
638 while P
< Name_Len
- 2 loop
639 if Name_Buffer
(P
) = '.' then
640 Name_Buffer
(P
+ 2 .. Name_Len
+ 1) :=
641 Name_Buffer
(P
+ 1 .. Name_Len
);
642 Name_Len
:= Name_Len
+ 1;
643 Name_Buffer
(P
) := '_';
644 Name_Buffer
(P
+ 1) := '_';
651 -- Create elaboration flag
654 Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
655 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
657 if No
(Declarations
(Aux_Decls_Node
(N
))) then
658 Set_Declarations
(Aux_Decls_Node
(N
), New_List
);
662 Make_Object_Declaration
(Loc
,
663 Defining_Identifier
=> Elab_Ent
,
665 New_Occurrence_Of
(Standard_Boolean
, Loc
),
667 New_Occurrence_Of
(Standard_False
, Loc
));
669 Append_To
(Declarations
(Aux_Decls_Node
(N
)), Decl
);
672 -- Reset True_Constant indication, since we will indeed
673 -- assign a value to the variable in the binder main.
675 Set_Is_True_Constant
(Elab_Ent
, False);
677 -- We do not want any further qualification of the name (if we did
678 -- not do this, we would pick up the name of the generic package
679 -- in the case of a library level generic instantiation).
681 Set_Has_Qualified_Name
(Elab_Ent
);
682 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
683 end Build_Elaboration_Entity
;
685 -----------------------------------
686 -- Cannot_Raise_Constraint_Error --
687 -----------------------------------
689 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
691 if Compile_Time_Known_Value
(Expr
) then
694 elsif Do_Range_Check
(Expr
) then
697 elsif Raises_Constraint_Error
(Expr
) then
705 when N_Expanded_Name
=>
708 when N_Selected_Component
=>
709 return not Do_Discriminant_Check
(Expr
);
711 when N_Attribute_Reference
=>
712 if Do_Overflow_Check
(Expr
)
713 or else Do_Access_Check
(Expr
)
717 elsif No
(Expressions
(Expr
)) then
722 N
: Node_Id
:= First
(Expressions
(Expr
));
725 while Present
(N
) loop
726 if Cannot_Raise_Constraint_Error
(N
) then
737 when N_Type_Conversion
=>
738 if Do_Overflow_Check
(Expr
)
739 or else Do_Length_Check
(Expr
)
740 or else Do_Tag_Check
(Expr
)
745 Cannot_Raise_Constraint_Error
(Expression
(Expr
));
748 when N_Unchecked_Type_Conversion
=>
749 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
752 if Do_Overflow_Check
(Expr
) then
756 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
763 if Do_Division_Check
(Expr
)
764 or else Do_Overflow_Check
(Expr
)
769 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
771 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
790 N_Op_Shift_Right_Arithmetic |
794 if Do_Overflow_Check
(Expr
) then
798 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
800 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
807 end Cannot_Raise_Constraint_Error
;
809 --------------------------
810 -- Check_Fully_Declared --
811 --------------------------
813 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
815 if Ekind
(T
) = E_Incomplete_Type
then
817 ("premature usage of incomplete}", N
, First_Subtype
(T
));
819 elsif Has_Private_Component
(T
)
820 and then not Is_Generic_Type
(Root_Type
(T
))
821 and then not In_Default_Expression
824 ("premature usage of incomplete}", N
, First_Subtype
(T
));
826 end Check_Fully_Declared
;
828 ------------------------------------------
829 -- Check_Potentially_Blocking_Operation --
830 ------------------------------------------
832 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
834 Loc
: constant Source_Ptr
:= Sloc
(N
);
837 -- N is one of the potentially blocking operations listed in
838 -- 9.5.1 (8). When using the Ravenscar profile, raise Program_Error
839 -- before N if the context is a protected action. Otherwise, only issue
840 -- a warning, since some users are relying on blocking operations
841 -- inside protected objects.
842 -- Indirect blocking through a subprogram call
843 -- cannot be diagnosed statically without interprocedural analysis,
844 -- so we do not attempt to do it here.
846 S
:= Scope
(Current_Scope
);
848 while Present
(S
) and then S
/= Standard_Standard
loop
849 if Is_Protected_Type
(S
) then
850 if Restricted_Profile
then
852 Make_Raise_Program_Error
(Loc
,
853 Reason
=> PE_Potentially_Blocking_Operation
));
854 Error_Msg_N
("potentially blocking operation, " &
855 " Program Error will be raised at run time?", N
);
859 ("potentially blocking operation in protected operation?", N
);
867 end Check_Potentially_Blocking_Operation
;
873 procedure Check_VMS
(Construct
: Node_Id
) is
875 if not OpenVMS_On_Target
then
877 ("this construct is allowed only in Open'V'M'S", Construct
);
881 ----------------------------------
882 -- Collect_Primitive_Operations --
883 ----------------------------------
885 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
886 B_Type
: constant Entity_Id
:= Base_Type
(T
);
887 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
888 B_Scope
: Entity_Id
:= Scope
(B_Type
);
892 Formal_Derived
: Boolean := False;
896 -- For tagged types, the primitive operations are collected as they
897 -- are declared, and held in an explicit list which is simply returned.
899 if Is_Tagged_Type
(B_Type
) then
900 return Primitive_Operations
(B_Type
);
902 -- An untagged generic type that is a derived type inherits the
903 -- primitive operations of its parent type. Other formal types only
904 -- have predefined operators, which are not explicitly represented.
906 elsif Is_Generic_Type
(B_Type
) then
907 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
908 and then Nkind
(Formal_Type_Definition
(B_Decl
))
909 = N_Formal_Derived_Type_Definition
911 Formal_Derived
:= True;
913 return New_Elmt_List
;
917 Op_List
:= New_Elmt_List
;
919 if B_Scope
= Standard_Standard
then
920 if B_Type
= Standard_String
then
921 Append_Elmt
(Standard_Op_Concat
, Op_List
);
923 elsif B_Type
= Standard_Wide_String
then
924 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
930 elsif (Is_Package
(B_Scope
)
932 Parent
(Declaration_Node
(First_Subtype
(T
))))
935 or else Is_Derived_Type
(B_Type
)
937 -- The primitive operations appear after the base type, except
938 -- if the derivation happens within the private part of B_Scope
939 -- and the type is a private type, in which case both the type
940 -- and some primitive operations may appear before the base
941 -- type, and the list of candidates starts after the type.
943 if In_Open_Scopes
(B_Scope
)
944 and then Scope
(T
) = B_Scope
945 and then In_Private_Part
(B_Scope
)
947 Id
:= Next_Entity
(T
);
949 Id
:= Next_Entity
(B_Type
);
952 while Present
(Id
) loop
954 -- Note that generic formal subprograms are not
955 -- considered to be primitive operations and thus
956 -- are never inherited.
958 if Is_Overloadable
(Id
)
959 and then Nkind
(Parent
(Parent
(Id
)))
960 /= N_Formal_Subprogram_Declaration
964 if Base_Type
(Etype
(Id
)) = B_Type
then
967 Formal
:= First_Formal
(Id
);
968 while Present
(Formal
) loop
969 if Base_Type
(Etype
(Formal
)) = B_Type
then
973 elsif Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
975 (Designated_Type
(Etype
(Formal
))) = B_Type
981 Next_Formal
(Formal
);
985 -- For a formal derived type, the only primitives are the
986 -- ones inherited from the parent type. Operations appearing
987 -- in the package declaration are not primitive for it.
990 and then (not Formal_Derived
991 or else Present
(Alias
(Id
)))
993 Append_Elmt
(Id
, Op_List
);
999 -- For a type declared in System, some of its operations
1000 -- may appear in the target-specific extension to System.
1003 and then Chars
(B_Scope
) = Name_System
1004 and then Scope
(B_Scope
) = Standard_Standard
1005 and then Present_System_Aux
1007 B_Scope
:= System_Aux_Id
;
1008 Id
:= First_Entity
(System_Aux_Id
);
1016 end Collect_Primitive_Operations
;
1018 -----------------------------------
1019 -- Compile_Time_Constraint_Error --
1020 -----------------------------------
1022 function Compile_Time_Constraint_Error
1025 Ent
: Entity_Id
:= Empty
;
1026 Loc
: Source_Ptr
:= No_Location
)
1029 Msgc
: String (1 .. Msg
'Length + 2);
1037 -- A static constraint error in an instance body is not a fatal error.
1038 -- we choose to inhibit the message altogether, because there is no
1039 -- obvious node (for now) on which to post it. On the other hand the
1040 -- offending node must be replaced with a constraint_error in any case.
1042 -- No messages are generated if we already posted an error on this node
1044 if not Error_Posted
(N
) then
1045 if Loc
/= No_Location
then
1051 -- Make all such messages unconditional
1053 Msgc
(1 .. Msg
'Length) := Msg
;
1054 Msgc
(Msg
'Length + 1) := '!';
1055 Msgl
:= Msg
'Length + 1;
1057 -- Message is a warning, even in Ada 95 case
1059 if Msg
(Msg
'Length) = '?' then
1062 -- In Ada 83, all messages are warnings. In the private part and
1063 -- the body of an instance, constraint_checks are only warnings.
1065 elsif Ada_83
and then Comes_From_Source
(N
) then
1071 elsif In_Instance_Not_Visible
then
1076 Warn_On_Instance
:= True;
1078 -- Otherwise we have a real error message (Ada 95 static case)
1084 -- Should we generate a warning? The answer is not quite yes. The
1085 -- very annoying exception occurs in the case of a short circuit
1086 -- operator where the left operand is static and decisive. Climb
1087 -- parents to see if that is the case we have here.
1095 if (Nkind
(P
) = N_And_Then
1096 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1097 and then Is_False
(Expr_Value
(Left_Opnd
(P
))))
1098 or else (Nkind
(P
) = N_Or_Else
1099 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1100 and then Is_True
(Expr_Value
(Left_Opnd
(P
))))
1105 elsif Nkind
(P
) = N_Component_Association
1106 and then Nkind
(Parent
(P
)) = N_Aggregate
1108 null; -- Keep going.
1111 exit when Nkind
(P
) not in N_Subexpr
;
1116 if Present
(Ent
) then
1117 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
1119 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
1123 if Inside_Init_Proc
then
1125 ("\& will be raised for objects of this type!?",
1126 N
, Standard_Constraint_Error
, Eloc
);
1129 ("\& will be raised at run time!?",
1130 N
, Standard_Constraint_Error
, Eloc
);
1134 ("\static expression raises&!",
1135 N
, Standard_Constraint_Error
, Eloc
);
1141 end Compile_Time_Constraint_Error
;
1143 -----------------------
1144 -- Conditional_Delay --
1145 -----------------------
1147 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
1149 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
1150 Set_Has_Delayed_Freeze
(New_Ent
);
1152 end Conditional_Delay
;
1154 --------------------
1155 -- Current_Entity --
1156 --------------------
1158 -- The currently visible definition for a given identifier is the
1159 -- one most chained at the start of the visibility chain, i.e. the
1160 -- one that is referenced by the Node_Id value of the name of the
1161 -- given identifier.
1163 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
1165 return Get_Name_Entity_Id
(Chars
(N
));
1168 -----------------------------
1169 -- Current_Entity_In_Scope --
1170 -----------------------------
1172 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
1174 CS
: constant Entity_Id
:= Current_Scope
;
1176 Transient_Case
: constant Boolean := Scope_Is_Transient
;
1179 E
:= Get_Name_Entity_Id
(Chars
(N
));
1182 and then Scope
(E
) /= CS
1183 and then (not Transient_Case
or else Scope
(E
) /= Scope
(CS
))
1189 end Current_Entity_In_Scope
;
1195 function Current_Scope
return Entity_Id
is
1197 if Scope_Stack
.Last
= -1 then
1198 return Standard_Standard
;
1201 C
: constant Entity_Id
:=
1202 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
1207 return Standard_Standard
;
1213 ------------------------
1214 -- Current_Subprogram --
1215 ------------------------
1217 function Current_Subprogram
return Entity_Id
is
1218 Scop
: constant Entity_Id
:= Current_Scope
;
1221 if Ekind
(Scop
) = E_Function
1223 Ekind
(Scop
) = E_Procedure
1225 Ekind
(Scop
) = E_Generic_Function
1227 Ekind
(Scop
) = E_Generic_Procedure
1232 return Enclosing_Subprogram
(Scop
);
1234 end Current_Subprogram
;
1236 ---------------------
1237 -- Defining_Entity --
1238 ---------------------
1240 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
1241 K
: constant Node_Kind
:= Nkind
(N
);
1242 Err
: Entity_Id
:= Empty
;
1247 N_Subprogram_Declaration |
1248 N_Abstract_Subprogram_Declaration |
1250 N_Package_Declaration |
1251 N_Subprogram_Renaming_Declaration |
1252 N_Subprogram_Body_Stub |
1253 N_Generic_Subprogram_Declaration |
1254 N_Generic_Package_Declaration |
1255 N_Formal_Subprogram_Declaration
1257 return Defining_Entity
(Specification
(N
));
1260 N_Component_Declaration |
1261 N_Defining_Program_Unit_Name |
1262 N_Discriminant_Specification |
1264 N_Entry_Declaration |
1265 N_Entry_Index_Specification |
1266 N_Exception_Declaration |
1267 N_Exception_Renaming_Declaration |
1268 N_Formal_Object_Declaration |
1269 N_Formal_Package_Declaration |
1270 N_Formal_Type_Declaration |
1271 N_Full_Type_Declaration |
1272 N_Implicit_Label_Declaration |
1273 N_Incomplete_Type_Declaration |
1274 N_Loop_Parameter_Specification |
1275 N_Number_Declaration |
1276 N_Object_Declaration |
1277 N_Object_Renaming_Declaration |
1278 N_Package_Body_Stub |
1279 N_Parameter_Specification |
1280 N_Private_Extension_Declaration |
1281 N_Private_Type_Declaration |
1283 N_Protected_Body_Stub |
1284 N_Protected_Type_Declaration |
1285 N_Single_Protected_Declaration |
1286 N_Single_Task_Declaration |
1287 N_Subtype_Declaration |
1290 N_Task_Type_Declaration
1292 return Defining_Identifier
(N
);
1295 return Defining_Entity
(Proper_Body
(N
));
1298 N_Function_Instantiation |
1299 N_Function_Specification |
1300 N_Generic_Function_Renaming_Declaration |
1301 N_Generic_Package_Renaming_Declaration |
1302 N_Generic_Procedure_Renaming_Declaration |
1304 N_Package_Instantiation |
1305 N_Package_Renaming_Declaration |
1306 N_Package_Specification |
1307 N_Procedure_Instantiation |
1308 N_Procedure_Specification
1311 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
1314 if Nkind
(Nam
) in N_Entity
then
1317 -- For Error, make up a name and attach to declaration
1318 -- so we can continue semantic analysis
1320 elsif Nam
= Error
then
1322 Make_Defining_Identifier
(Sloc
(N
),
1323 Chars
=> New_Internal_Name
('T'));
1324 Set_Defining_Unit_Name
(N
, Err
);
1327 -- If not an entity, get defining identifier
1330 return Defining_Identifier
(Nam
);
1334 when N_Block_Statement
=>
1335 return Entity
(Identifier
(N
));
1338 raise Program_Error
;
1341 end Defining_Entity
;
1343 --------------------------
1344 -- Denotes_Discriminant --
1345 --------------------------
1347 function Denotes_Discriminant
(N
: Node_Id
) return Boolean is
1349 return Is_Entity_Name
(N
)
1350 and then Present
(Entity
(N
))
1351 and then Ekind
(Entity
(N
)) = E_Discriminant
;
1352 end Denotes_Discriminant
;
1354 -----------------------------
1355 -- Depends_On_Discriminant --
1356 -----------------------------
1358 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
1363 Get_Index_Bounds
(N
, L
, H
);
1364 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
1365 end Depends_On_Discriminant
;
1367 -------------------------
1368 -- Designate_Same_Unit --
1369 -------------------------
1371 function Designate_Same_Unit
1376 K1
: Node_Kind
:= Nkind
(Name1
);
1377 K2
: Node_Kind
:= Nkind
(Name2
);
1379 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
1380 -- Returns the parent unit name node of a defining program unit name
1381 -- or the prefix if N is a selected component or an expanded name.
1383 function Select_Node
(N
: Node_Id
) return Node_Id
;
1384 -- Returns the defining identifier node of a defining program unit
1385 -- name or the selector node if N is a selected component or an
1388 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
1390 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1398 function Select_Node
(N
: Node_Id
) return Node_Id
is
1400 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
1401 return Defining_Identifier
(N
);
1404 return Selector_Name
(N
);
1408 -- Start of processing for Designate_Next_Unit
1411 if (K1
= N_Identifier
or else
1412 K1
= N_Defining_Identifier
)
1414 (K2
= N_Identifier
or else
1415 K2
= N_Defining_Identifier
)
1417 return Chars
(Name1
) = Chars
(Name2
);
1420 (K1
= N_Expanded_Name
or else
1421 K1
= N_Selected_Component
or else
1422 K1
= N_Defining_Program_Unit_Name
)
1424 (K2
= N_Expanded_Name
or else
1425 K2
= N_Selected_Component
or else
1426 K2
= N_Defining_Program_Unit_Name
)
1429 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
1431 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
1436 end Designate_Same_Unit
;
1438 ----------------------------
1439 -- Enclosing_Generic_Body --
1440 ----------------------------
1442 function Enclosing_Generic_Body
1453 while Present
(P
) loop
1454 if Nkind
(P
) = N_Package_Body
1455 or else Nkind
(P
) = N_Subprogram_Body
1457 Spec
:= Corresponding_Spec
(P
);
1459 if Present
(Spec
) then
1460 Decl
:= Unit_Declaration_Node
(Spec
);
1462 if Nkind
(Decl
) = N_Generic_Package_Declaration
1463 or else Nkind
(Decl
) = N_Generic_Subprogram_Declaration
1474 end Enclosing_Generic_Body
;
1476 -------------------------------
1477 -- Enclosing_Lib_Unit_Entity --
1478 -------------------------------
1480 function Enclosing_Lib_Unit_Entity
return Entity_Id
is
1481 Unit_Entity
: Entity_Id
:= Current_Scope
;
1484 -- Look for enclosing library unit entity by following scope links.
1485 -- Equivalent to, but faster than indexing through the scope stack.
1487 while (Present
(Scope
(Unit_Entity
))
1488 and then Scope
(Unit_Entity
) /= Standard_Standard
)
1489 and not Is_Child_Unit
(Unit_Entity
)
1491 Unit_Entity
:= Scope
(Unit_Entity
);
1495 end Enclosing_Lib_Unit_Entity
;
1497 -----------------------------
1498 -- Enclosing_Lib_Unit_Node --
1499 -----------------------------
1501 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
1502 Current_Node
: Node_Id
:= N
;
1505 while Present
(Current_Node
)
1506 and then Nkind
(Current_Node
) /= N_Compilation_Unit
1508 Current_Node
:= Parent
(Current_Node
);
1511 if Nkind
(Current_Node
) /= N_Compilation_Unit
then
1515 return Current_Node
;
1516 end Enclosing_Lib_Unit_Node
;
1518 --------------------------
1519 -- Enclosing_Subprogram --
1520 --------------------------
1522 function Enclosing_Subprogram
(E
: Entity_Id
) return Entity_Id
is
1523 Dynamic_Scope
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(E
);
1526 if Dynamic_Scope
= Standard_Standard
then
1529 elsif Ekind
(Dynamic_Scope
) = E_Subprogram_Body
then
1530 return Corresponding_Spec
(Parent
(Parent
(Dynamic_Scope
)));
1532 elsif Ekind
(Dynamic_Scope
) = E_Block
then
1533 return Enclosing_Subprogram
(Dynamic_Scope
);
1535 elsif Ekind
(Dynamic_Scope
) = E_Task_Type
then
1536 return Get_Task_Body_Procedure
(Dynamic_Scope
);
1538 elsif Convention
(Dynamic_Scope
) = Convention_Protected
then
1539 return Protected_Body_Subprogram
(Dynamic_Scope
);
1542 return Dynamic_Scope
;
1544 end Enclosing_Subprogram
;
1546 ------------------------
1547 -- Ensure_Freeze_Node --
1548 ------------------------
1550 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
1554 if No
(Freeze_Node
(E
)) then
1555 FN
:= Make_Freeze_Entity
(Sloc
(E
));
1556 Set_Has_Delayed_Freeze
(E
);
1557 Set_Freeze_Node
(E
, FN
);
1558 Set_Access_Types_To_Process
(FN
, No_Elist
);
1559 Set_TSS_Elist
(FN
, No_Elist
);
1562 end Ensure_Freeze_Node
;
1568 procedure Enter_Name
(Def_Id
: Node_Id
) is
1569 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
1570 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
1571 S
: constant Entity_Id
:= Current_Scope
;
1574 Generate_Definition
(Def_Id
);
1576 -- Add new name to current scope declarations. Check for duplicate
1577 -- declaration, which may or may not be a genuine error.
1581 -- Case of previous entity entered because of a missing declaration
1582 -- or else a bad subtype indication. Best is to use the new entity,
1583 -- and make the previous one invisible.
1585 if Etype
(E
) = Any_Type
then
1586 Set_Is_Immediately_Visible
(E
, False);
1588 -- Case of renaming declaration constructed for package instances.
1589 -- if there is an explicit declaration with the same identifier,
1590 -- the renaming is not immediately visible any longer, but remains
1591 -- visible through selected component notation.
1593 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
1594 and then not Comes_From_Source
(E
)
1596 Set_Is_Immediately_Visible
(E
, False);
1598 -- The new entity may be the package renaming, which has the same
1599 -- same name as a generic formal which has been seen already.
1601 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
1602 and then not Comes_From_Source
(Def_Id
)
1604 Set_Is_Immediately_Visible
(E
, False);
1606 -- For a fat pointer corresponding to a remote access to subprogram,
1607 -- we use the same identifier as the RAS type, so that the proper
1608 -- name appears in the stub. This type is only retrieved through
1609 -- the RAS type and never by visibility, and is not added to the
1610 -- visibility list (see below).
1612 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
1613 and then Present
(Corresponding_Remote_Type
(Def_Id
))
1617 -- A controller component for a type extension overrides the
1618 -- inherited component.
1620 elsif Chars
(E
) = Name_uController
then
1623 -- Case of an implicit operation or derived literal. The new entity
1624 -- hides the implicit one, which is removed from all visibility,
1625 -- i.e. the entity list of its scope, and homonym chain of its name.
1627 elsif (Is_Overloadable
(E
) and then Present
(Alias
(E
)))
1628 or else Is_Internal
(E
)
1629 or else (Ekind
(E
) = E_Enumeration_Literal
1630 and then Is_Derived_Type
(Etype
(E
)))
1634 Prev_Vis
: Entity_Id
;
1637 -- If E is an implicit declaration, it cannot be the first
1638 -- entity in the scope.
1640 Prev
:= First_Entity
(Current_Scope
);
1642 while Next_Entity
(Prev
) /= E
loop
1646 Set_Next_Entity
(Prev
, Next_Entity
(E
));
1648 if No
(Next_Entity
(Prev
)) then
1649 Set_Last_Entity
(Current_Scope
, Prev
);
1652 if E
= Current_Entity
(E
) then
1655 Prev_Vis
:= Current_Entity
(E
);
1656 while Homonym
(Prev_Vis
) /= E
loop
1657 Prev_Vis
:= Homonym
(Prev_Vis
);
1661 if Present
(Prev_Vis
) then
1663 -- Skip E in the visibility chain
1665 Set_Homonym
(Prev_Vis
, Homonym
(E
));
1668 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
1672 -- This section of code could use a comment ???
1674 elsif Present
(Etype
(E
))
1675 and then Is_Concurrent_Type
(Etype
(E
))
1680 -- In the body or private part of an instance, a type extension
1681 -- may introduce a component with the same name as that of an
1682 -- actual. The legality rule is not enforced, but the semantics
1683 -- of the full type with two components of the same name are not
1684 -- clear at this point ???
1686 elsif In_Instance_Not_Visible
then
1689 -- When compiling a package body, some child units may have become
1690 -- visible. They cannot conflict with local entities that hide them.
1692 elsif Is_Child_Unit
(E
)
1693 and then In_Open_Scopes
(Scope
(E
))
1694 and then not Is_Immediately_Visible
(E
)
1698 -- Conversely, with front-end inlining we may compile the parent
1699 -- body first, and a child unit subsequently. The context is now
1700 -- the parent spec, and body entities are not visible.
1702 elsif Is_Child_Unit
(Def_Id
)
1703 and then Is_Package_Body_Entity
(E
)
1704 and then not In_Package_Body
(Current_Scope
)
1708 -- Case of genuine duplicate declaration
1711 Error_Msg_Sloc
:= Sloc
(E
);
1713 -- If the previous declaration is an incomplete type declaration
1714 -- this may be an attempt to complete it with a private type.
1715 -- The following avoids confusing cascaded errors.
1717 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
1718 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
1721 ("incomplete type cannot be completed" &
1722 " with a private declaration",
1724 Set_Is_Immediately_Visible
(E
, False);
1725 Set_Full_View
(E
, Def_Id
);
1727 elsif Ekind
(E
) = E_Discriminant
1728 and then Present
(Scope
(Def_Id
))
1729 and then Scope
(Def_Id
) /= Current_Scope
1731 -- An inherited component of a record conflicts with
1732 -- a new discriminant. The discriminant is inserted first
1733 -- in the scope, but the error should be posted on it, not
1734 -- on the component.
1736 Error_Msg_Sloc
:= Sloc
(Def_Id
);
1737 Error_Msg_N
("& conflicts with declaration#", E
);
1740 -- If the name of the unit appears in its own context clause,
1741 -- a dummy package with the name has already been created, and
1742 -- the error emitted. Try to continue quietly.
1744 elsif Error_Posted
(E
)
1745 and then Sloc
(E
) = No_Location
1746 and then Nkind
(Parent
(E
)) = N_Package_Specification
1747 and then Current_Scope
= Standard_Standard
1749 Set_Scope
(Def_Id
, Current_Scope
);
1753 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
1755 -- Avoid cascaded messages with duplicate components in
1758 if Ekind
(E
) = E_Component
1759 or else Ekind
(E
) = E_Discriminant
1765 if Nkind
(Parent
(Parent
(Def_Id
)))
1766 = N_Generic_Subprogram_Declaration
1768 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
1770 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
1773 -- If entity is in standard, then we are in trouble, because
1774 -- it means that we have a library package with a duplicated
1775 -- name. That's hard to recover from, so abort!
1777 if S
= Standard_Standard
then
1778 raise Unrecoverable_Error
;
1780 -- Otherwise we continue with the declaration. Having two
1781 -- identical declarations should not cause us too much trouble!
1789 -- If we fall through, declaration is OK , or OK enough to continue
1791 -- If Def_Id is a discriminant or a record component we are in the
1792 -- midst of inheriting components in a derived record definition.
1793 -- Preserve their Ekind and Etype.
1795 if Ekind
(Def_Id
) = E_Discriminant
1796 or else Ekind
(Def_Id
) = E_Component
1800 -- If a type is already set, leave it alone (happens whey a type
1801 -- declaration is reanalyzed following a call to the optimizer)
1803 elsif Present
(Etype
(Def_Id
)) then
1806 -- Otherwise, the kind E_Void insures that premature uses of the entity
1807 -- will be detected. Any_Type insures that no cascaded errors will occur
1810 Set_Ekind
(Def_Id
, E_Void
);
1811 Set_Etype
(Def_Id
, Any_Type
);
1814 -- Inherited discriminants and components in derived record types are
1815 -- immediately visible. Itypes are not.
1817 if Ekind
(Def_Id
) = E_Discriminant
1818 or else Ekind
(Def_Id
) = E_Component
1819 or else (No
(Corresponding_Remote_Type
(Def_Id
))
1820 and then not Is_Itype
(Def_Id
))
1822 Set_Is_Immediately_Visible
(Def_Id
);
1823 Set_Current_Entity
(Def_Id
);
1826 Set_Homonym
(Def_Id
, C
);
1827 Append_Entity
(Def_Id
, S
);
1828 Set_Public_Status
(Def_Id
);
1830 -- Warn if new entity hides an old one
1833 and then Length_Of_Name
(Chars
(C
)) /= 1
1834 and then Present
(C
)
1835 and then Comes_From_Source
(C
)
1836 and then Comes_From_Source
(Def_Id
)
1837 and then In_Extended_Main_Source_Unit
(Def_Id
)
1839 Error_Msg_Sloc
:= Sloc
(C
);
1840 Error_Msg_N
("declaration hides &#?", Def_Id
);
1845 -------------------------------------
1846 -- Find_Corresponding_Discriminant --
1847 -------------------------------------
1849 function Find_Corresponding_Discriminant
1854 Par_Disc
: Entity_Id
;
1855 Old_Disc
: Entity_Id
;
1856 New_Disc
: Entity_Id
;
1859 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
1860 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
1862 if Is_Class_Wide_Type
(Typ
) then
1863 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
1865 New_Disc
:= First_Discriminant
(Typ
);
1868 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
1869 if Old_Disc
= Par_Disc
then
1872 Next_Discriminant
(Old_Disc
);
1873 Next_Discriminant
(New_Disc
);
1877 -- Should always find it
1879 raise Program_Error
;
1880 end Find_Corresponding_Discriminant
;
1886 function First_Actual
(Node
: Node_Id
) return Node_Id
is
1890 if No
(Parameter_Associations
(Node
)) then
1894 N
:= First
(Parameter_Associations
(Node
));
1896 if Nkind
(N
) = N_Parameter_Association
then
1897 return First_Named_Actual
(Node
);
1903 -------------------------
1904 -- Full_Qualified_Name --
1905 -------------------------
1907 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
1911 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
;
1912 -- Compute recursively the qualified name without NUL at the end.
1914 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
1915 Ent
: Entity_Id
:= E
;
1916 Parent_Name
: String_Id
:= No_String
;
1919 -- Deals properly with child units
1921 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
1922 Ent
:= Defining_Identifier
(Ent
);
1925 -- Compute recursively the qualification. Only "Standard" has no
1928 if Present
(Scope
(Scope
(Ent
))) then
1929 Parent_Name
:= Internal_Full_Qualified_Name
(Scope
(Ent
));
1932 -- Every entity should have a name except some expanded blocks
1933 -- don't bother about those.
1935 if Chars
(Ent
) = No_Name
then
1939 -- Add a period between Name and qualification
1941 if Parent_Name
/= No_String
then
1942 Start_String
(Parent_Name
);
1943 Store_String_Char
(Get_Char_Code
('.'));
1949 -- Generates the entity name in upper case
1951 Get_Name_String
(Chars
(Ent
));
1953 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
1955 end Internal_Full_Qualified_Name
;
1958 Res
:= Internal_Full_Qualified_Name
(E
);
1959 Store_String_Char
(Get_Char_Code
(ASCII
.nul
));
1961 end Full_Qualified_Name
;
1963 -----------------------
1964 -- Gather_Components --
1965 -----------------------
1967 procedure Gather_Components
1969 Comp_List
: Node_Id
;
1970 Governed_By
: List_Id
;
1972 Report_Errors
: out Boolean)
1976 Discrete_Choice
: Node_Id
;
1977 Comp_Item
: Node_Id
;
1979 Discrim
: Entity_Id
;
1980 Discrim_Name
: Node_Id
;
1981 Discrim_Value
: Node_Id
;
1984 Report_Errors
:= False;
1986 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
1989 elsif Present
(Component_Items
(Comp_List
)) then
1990 Comp_Item
:= First
(Component_Items
(Comp_List
));
1996 while Present
(Comp_Item
) loop
1998 -- Skip the tag of a tagged record, as well as all items
1999 -- that are not user components (anonymous types, rep clauses,
2000 -- Parent field, controller field).
2002 if Nkind
(Comp_Item
) = N_Component_Declaration
2003 and then Chars
(Defining_Identifier
(Comp_Item
)) /= Name_uTag
2004 and then Chars
(Defining_Identifier
(Comp_Item
)) /= Name_uParent
2005 and then Chars
(Defining_Identifier
(Comp_Item
)) /= Name_uController
2007 Append_Elmt
(Defining_Identifier
(Comp_Item
), Into
);
2013 if No
(Variant_Part
(Comp_List
)) then
2016 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
2017 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
2020 -- Look for the discriminant that governs this variant part.
2021 -- The discriminant *must* be in the Governed_By List
2023 Assoc
:= First
(Governed_By
);
2024 Find_Constraint
: loop
2025 Discrim
:= First
(Choices
(Assoc
));
2026 exit Find_Constraint
when Chars
(Discrim_Name
) = Chars
(Discrim
)
2027 or else (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
2029 Chars
(Corresponding_Discriminant
(Entity
(Discrim
)))
2030 = Chars
(Discrim_Name
))
2031 or else Chars
(Original_Record_Component
(Entity
(Discrim
)))
2032 = Chars
(Discrim_Name
);
2034 if No
(Next
(Assoc
)) then
2035 if not Is_Constrained
(Typ
)
2036 and then Is_Derived_Type
(Typ
)
2037 and then Present
(Girder_Constraint
(Typ
))
2040 -- If the type is a tagged type with inherited discriminants,
2041 -- use the girder constraint on the parent in order to find
2042 -- the values of discriminants that are otherwise hidden by an
2043 -- explicit constraint. Renamed discriminants are handled in
2051 D
:= First_Discriminant
(Etype
(Typ
));
2052 C
:= First_Elmt
(Girder_Constraint
(Typ
));
2055 and then Present
(C
)
2057 if Chars
(Discrim_Name
) = Chars
(D
) then
2059 Make_Component_Association
(Sloc
(Typ
),
2061 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
2062 Duplicate_Subexpr_No_Checks
(Node
(C
)));
2063 exit Find_Constraint
;
2066 D
:= Next_Discriminant
(D
);
2073 if No
(Next
(Assoc
)) then
2074 Error_Msg_NE
(" missing value for discriminant&",
2075 First
(Governed_By
), Discrim_Name
);
2076 Report_Errors
:= True;
2081 end loop Find_Constraint
;
2083 Discrim_Value
:= Expression
(Assoc
);
2085 if not Is_OK_Static_Expression
(Discrim_Value
) then
2087 ("value for discriminant & must be static", Discrim_Value
, Discrim
);
2088 Report_Errors
:= True;
2092 Search_For_Discriminant_Value
: declare
2098 UI_Discrim_Value
: constant Uint
:= Expr_Value
(Discrim_Value
);
2101 Find_Discrete_Value
: while Present
(Variant
) loop
2102 Discrete_Choice
:= First
(Discrete_Choices
(Variant
));
2103 while Present
(Discrete_Choice
) loop
2105 exit Find_Discrete_Value
when
2106 Nkind
(Discrete_Choice
) = N_Others_Choice
;
2108 Get_Index_Bounds
(Discrete_Choice
, Low
, High
);
2110 UI_Low
:= Expr_Value
(Low
);
2111 UI_High
:= Expr_Value
(High
);
2113 exit Find_Discrete_Value
when
2114 UI_Low
<= UI_Discrim_Value
2116 UI_High
>= UI_Discrim_Value
;
2118 Next
(Discrete_Choice
);
2121 Next_Non_Pragma
(Variant
);
2122 end loop Find_Discrete_Value
;
2123 end Search_For_Discriminant_Value
;
2125 if No
(Variant
) then
2127 ("value of discriminant & is out of range", Discrim_Value
, Discrim
);
2128 Report_Errors
:= True;
2132 -- If we have found the corresponding choice, recursively add its
2133 -- components to the Into list.
2135 Gather_Components
(Empty
,
2136 Component_List
(Variant
), Governed_By
, Into
, Report_Errors
);
2137 end Gather_Components
;
2139 ------------------------
2140 -- Get_Actual_Subtype --
2141 ------------------------
2143 function Get_Actual_Subtype
(N
: Node_Id
) return Entity_Id
is
2144 Typ
: constant Entity_Id
:= Etype
(N
);
2145 Utyp
: Entity_Id
:= Underlying_Type
(Typ
);
2150 if not Present
(Utyp
) then
2154 -- If what we have is an identifier that references a subprogram
2155 -- formal, or a variable or constant object, then we get the actual
2156 -- subtype from the referenced entity if one has been built.
2158 if Nkind
(N
) = N_Identifier
2160 (Is_Formal
(Entity
(N
))
2161 or else Ekind
(Entity
(N
)) = E_Constant
2162 or else Ekind
(Entity
(N
)) = E_Variable
)
2163 and then Present
(Actual_Subtype
(Entity
(N
)))
2165 return Actual_Subtype
(Entity
(N
));
2167 -- Actual subtype of unchecked union is always itself. We never need
2168 -- the "real" actual subtype. If we did, we couldn't get it anyway
2169 -- because the discriminant is not available. The restrictions on
2170 -- Unchecked_Union are designed to make sure that this is OK.
2172 elsif Is_Unchecked_Union
(Utyp
) then
2175 -- Here for the unconstrained case, we must find actual subtype
2176 -- No actual subtype is available, so we must build it on the fly.
2178 -- Checking the type, not the underlying type, for constrainedness
2179 -- seems to be necessary. Maybe all the tests should be on the type???
2181 elsif (not Is_Constrained
(Typ
))
2182 and then (Is_Array_Type
(Utyp
)
2183 or else (Is_Record_Type
(Utyp
)
2184 and then Has_Discriminants
(Utyp
)))
2185 and then not Has_Unknown_Discriminants
(Utyp
)
2186 and then not (Ekind
(Utyp
) = E_String_Literal_Subtype
)
2188 -- Nothing to do if in default expression
2190 if In_Default_Expression
then
2193 -- Else build the actual subtype
2196 Decl
:= Build_Actual_Subtype
(Typ
, N
);
2197 Atyp
:= Defining_Identifier
(Decl
);
2199 -- If Build_Actual_Subtype generated a new declaration then use it
2203 -- The actual subtype is an Itype, so analyze the declaration,
2204 -- but do not attach it to the tree, to get the type defined.
2206 Set_Parent
(Decl
, N
);
2207 Set_Is_Itype
(Atyp
);
2208 Analyze
(Decl
, Suppress
=> All_Checks
);
2209 Set_Associated_Node_For_Itype
(Atyp
, N
);
2210 Set_Has_Delayed_Freeze
(Atyp
, False);
2212 -- We need to freeze the actual subtype immediately. This is
2213 -- needed, because otherwise this Itype will not get frozen
2214 -- at all, and it is always safe to freeze on creation because
2215 -- any associated types must be frozen at this point.
2217 Freeze_Itype
(Atyp
, N
);
2220 -- Otherwise we did not build a declaration, so return original
2227 -- For all remaining cases, the actual subtype is the same as
2228 -- the nominal type.
2233 end Get_Actual_Subtype
;
2235 -------------------------------------
2236 -- Get_Actual_Subtype_If_Available --
2237 -------------------------------------
2239 function Get_Actual_Subtype_If_Available
(N
: Node_Id
) return Entity_Id
is
2240 Typ
: constant Entity_Id
:= Etype
(N
);
2243 -- If what we have is an identifier that references a subprogram
2244 -- formal, or a variable or constant object, then we get the actual
2245 -- subtype from the referenced entity if one has been built.
2247 if Nkind
(N
) = N_Identifier
2249 (Is_Formal
(Entity
(N
))
2250 or else Ekind
(Entity
(N
)) = E_Constant
2251 or else Ekind
(Entity
(N
)) = E_Variable
)
2252 and then Present
(Actual_Subtype
(Entity
(N
)))
2254 return Actual_Subtype
(Entity
(N
));
2256 -- Otherwise the Etype of N is returned unchanged
2261 end Get_Actual_Subtype_If_Available
;
2263 -------------------------------
2264 -- Get_Default_External_Name --
2265 -------------------------------
2267 function Get_Default_External_Name
(E
: Node_Or_Entity_Id
) return Node_Id
is
2269 Get_Decoded_Name_String
(Chars
(E
));
2271 if Opt
.External_Name_Imp_Casing
= Uppercase
then
2272 Set_Casing
(All_Upper_Case
);
2274 Set_Casing
(All_Lower_Case
);
2278 Make_String_Literal
(Sloc
(E
),
2279 Strval
=> String_From_Name_Buffer
);
2281 end Get_Default_External_Name
;
2283 ---------------------------
2284 -- Get_Enum_Lit_From_Pos --
2285 ---------------------------
2287 function Get_Enum_Lit_From_Pos
2294 P
: constant Nat
:= UI_To_Int
(Pos
);
2297 -- In the case where the literal is either of type Wide_Character
2298 -- or Character or of a type derived from them, there needs to be
2299 -- some special handling since there is no explicit chain of
2300 -- literals to search. Instead, an N_Character_Literal node is
2301 -- created with the appropriate Char_Code and Chars fields.
2303 if Root_Type
(T
) = Standard_Character
2304 or else Root_Type
(T
) = Standard_Wide_Character
2306 Set_Character_Literal_Name
(Char_Code
(P
));
2308 Make_Character_Literal
(Loc
,
2310 Char_Literal_Value
=> Char_Code
(P
));
2312 -- For all other cases, we have a complete table of literals, and
2313 -- we simply iterate through the chain of literal until the one
2314 -- with the desired position value is found.
2318 Lit
:= First_Literal
(Base_Type
(T
));
2319 for J
in 1 .. P
loop
2323 return New_Occurrence_Of
(Lit
, Loc
);
2325 end Get_Enum_Lit_From_Pos
;
2327 ------------------------
2328 -- Get_Generic_Entity --
2329 ------------------------
2331 function Get_Generic_Entity
(N
: Node_Id
) return Entity_Id
is
2332 Ent
: constant Entity_Id
:= Entity
(Name
(N
));
2335 if Present
(Renamed_Object
(Ent
)) then
2336 return Renamed_Object
(Ent
);
2340 end Get_Generic_Entity
;
2342 ----------------------
2343 -- Get_Index_Bounds --
2344 ----------------------
2346 procedure Get_Index_Bounds
(N
: Node_Id
; L
, H
: out Node_Id
) is
2347 Kind
: constant Node_Kind
:= Nkind
(N
);
2351 if Kind
= N_Range
then
2353 H
:= High_Bound
(N
);
2355 elsif Kind
= N_Subtype_Indication
then
2356 R
:= Range_Expression
(Constraint
(N
));
2364 L
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
2365 H
:= High_Bound
(Range_Expression
(Constraint
(N
)));
2368 elsif Is_Entity_Name
(N
) and then Is_Type
(Entity
(N
)) then
2369 if Error_Posted
(Scalar_Range
(Entity
(N
))) then
2373 elsif Nkind
(Scalar_Range
(Entity
(N
))) = N_Subtype_Indication
then
2374 Get_Index_Bounds
(Scalar_Range
(Entity
(N
)), L
, H
);
2377 L
:= Low_Bound
(Scalar_Range
(Entity
(N
)));
2378 H
:= High_Bound
(Scalar_Range
(Entity
(N
)));
2382 -- N is an expression, indicating a range with one value.
2387 end Get_Index_Bounds
;
2389 ------------------------
2390 -- Get_Name_Entity_Id --
2391 ------------------------
2393 function Get_Name_Entity_Id
(Id
: Name_Id
) return Entity_Id
is
2395 return Entity_Id
(Get_Name_Table_Info
(Id
));
2396 end Get_Name_Entity_Id
;
2398 ---------------------------
2399 -- Get_Referenced_Object --
2400 ---------------------------
2402 function Get_Referenced_Object
(N
: Node_Id
) return Node_Id
is
2406 while Is_Entity_Name
(R
)
2407 and then Present
(Renamed_Object
(Entity
(R
)))
2409 R
:= Renamed_Object
(Entity
(R
));
2413 end Get_Referenced_Object
;
2415 -------------------------
2416 -- Get_Subprogram_Body --
2417 -------------------------
2419 function Get_Subprogram_Body
(E
: Entity_Id
) return Node_Id
is
2423 Decl
:= Unit_Declaration_Node
(E
);
2425 if Nkind
(Decl
) = N_Subprogram_Body
then
2428 else -- Nkind (Decl) = N_Subprogram_Declaration
2430 if Present
(Corresponding_Body
(Decl
)) then
2431 return Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2433 else -- imported subprogram.
2437 end Get_Subprogram_Body
;
2439 -----------------------------
2440 -- Get_Task_Body_Procedure --
2441 -----------------------------
2443 function Get_Task_Body_Procedure
(E
: Entity_Id
) return Node_Id
is
2445 return Task_Body_Procedure
(Declaration_Node
(Root_Type
(E
)));
2446 end Get_Task_Body_Procedure
;
2448 --------------------
2449 -- Has_Infinities --
2450 --------------------
2452 function Has_Infinities
(E
: Entity_Id
) return Boolean is
2455 Is_Floating_Point_Type
(E
)
2456 and then Nkind
(Scalar_Range
(E
)) = N_Range
2457 and then Includes_Infinities
(Scalar_Range
(E
));
2460 ---------------------------
2461 -- Has_Private_Component --
2462 ---------------------------
2464 function Has_Private_Component
(Type_Id
: Entity_Id
) return Boolean is
2465 Btype
: Entity_Id
:= Base_Type
(Type_Id
);
2466 Component
: Entity_Id
;
2469 if Error_Posted
(Type_Id
)
2470 or else Error_Posted
(Btype
)
2475 if Is_Class_Wide_Type
(Btype
) then
2476 Btype
:= Root_Type
(Btype
);
2479 if Is_Private_Type
(Btype
) then
2481 UT
: constant Entity_Id
:= Underlying_Type
(Btype
);
2485 if No
(Full_View
(Btype
)) then
2486 return not Is_Generic_Type
(Btype
)
2487 and then not Is_Generic_Type
(Root_Type
(Btype
));
2490 return not Is_Generic_Type
(Root_Type
(Full_View
(Btype
)));
2494 return not Is_Frozen
(UT
) and then Has_Private_Component
(UT
);
2497 elsif Is_Array_Type
(Btype
) then
2498 return Has_Private_Component
(Component_Type
(Btype
));
2500 elsif Is_Record_Type
(Btype
) then
2502 Component
:= First_Component
(Btype
);
2503 while Present
(Component
) loop
2505 if Has_Private_Component
(Etype
(Component
)) then
2509 Next_Component
(Component
);
2514 elsif Is_Protected_Type
(Btype
)
2515 and then Present
(Corresponding_Record_Type
(Btype
))
2517 return Has_Private_Component
(Corresponding_Record_Type
(Btype
));
2522 end Has_Private_Component
;
2524 --------------------------
2525 -- Has_Tagged_Component --
2526 --------------------------
2528 function Has_Tagged_Component
(Typ
: Entity_Id
) return Boolean is
2532 if Is_Private_Type
(Typ
)
2533 and then Present
(Underlying_Type
(Typ
))
2535 return Has_Tagged_Component
(Underlying_Type
(Typ
));
2537 elsif Is_Array_Type
(Typ
) then
2538 return Has_Tagged_Component
(Component_Type
(Typ
));
2540 elsif Is_Tagged_Type
(Typ
) then
2543 elsif Is_Record_Type
(Typ
) then
2544 Comp
:= First_Component
(Typ
);
2546 while Present
(Comp
) loop
2547 if Has_Tagged_Component
(Etype
(Comp
)) then
2551 Comp
:= Next_Component
(Typ
);
2559 end Has_Tagged_Component
;
2565 function In_Instance
return Boolean is
2566 S
: Entity_Id
:= Current_Scope
;
2570 and then S
/= Standard_Standard
2572 if (Ekind
(S
) = E_Function
2573 or else Ekind
(S
) = E_Package
2574 or else Ekind
(S
) = E_Procedure
)
2575 and then Is_Generic_Instance
(S
)
2586 ----------------------
2587 -- In_Instance_Body --
2588 ----------------------
2590 function In_Instance_Body
return Boolean is
2591 S
: Entity_Id
:= Current_Scope
;
2595 and then S
/= Standard_Standard
2597 if (Ekind
(S
) = E_Function
2598 or else Ekind
(S
) = E_Procedure
)
2599 and then Is_Generic_Instance
(S
)
2603 elsif Ekind
(S
) = E_Package
2604 and then In_Package_Body
(S
)
2605 and then Is_Generic_Instance
(S
)
2614 end In_Instance_Body
;
2616 -----------------------------
2617 -- In_Instance_Not_Visible --
2618 -----------------------------
2620 function In_Instance_Not_Visible
return Boolean is
2621 S
: Entity_Id
:= Current_Scope
;
2625 and then S
/= Standard_Standard
2627 if (Ekind
(S
) = E_Function
2628 or else Ekind
(S
) = E_Procedure
)
2629 and then Is_Generic_Instance
(S
)
2633 elsif Ekind
(S
) = E_Package
2634 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
2635 and then Is_Generic_Instance
(S
)
2644 end In_Instance_Not_Visible
;
2646 ------------------------------
2647 -- In_Instance_Visible_Part --
2648 ------------------------------
2650 function In_Instance_Visible_Part
return Boolean is
2651 S
: Entity_Id
:= Current_Scope
;
2655 and then S
/= Standard_Standard
2657 if Ekind
(S
) = E_Package
2658 and then Is_Generic_Instance
(S
)
2659 and then not In_Package_Body
(S
)
2660 and then not In_Private_Part
(S
)
2669 end In_Instance_Visible_Part
;
2671 --------------------------------------
2672 -- In_Subprogram_Or_Concurrent_Unit --
2673 --------------------------------------
2675 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
2680 -- Use scope chain to check successively outer scopes
2686 if K
in Subprogram_Kind
2687 or else K
in Concurrent_Kind
2688 or else K
= E_Generic_Procedure
2689 or else K
= E_Generic_Function
2693 elsif E
= Standard_Standard
then
2700 end In_Subprogram_Or_Concurrent_Unit
;
2702 ---------------------
2703 -- In_Visible_Part --
2704 ---------------------
2706 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
2709 Is_Package
(Scope_Id
)
2710 and then In_Open_Scopes
(Scope_Id
)
2711 and then not In_Package_Body
(Scope_Id
)
2712 and then not In_Private_Part
(Scope_Id
);
2713 end In_Visible_Part
;
2719 function Is_AAMP_Float
(E
: Entity_Id
) return Boolean is
2721 pragma Assert
(Is_Type
(E
));
2723 return AAMP_On_Target
2724 and then Is_Floating_Point_Type
(E
)
2725 and then E
= Base_Type
(E
);
2728 -------------------------
2729 -- Is_Actual_Parameter --
2730 -------------------------
2732 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
2733 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
2737 when N_Parameter_Association
=>
2738 return N
= Explicit_Actual_Parameter
(Parent
(N
));
2740 when N_Function_Call | N_Procedure_Call_Statement
=>
2741 return Is_List_Member
(N
)
2743 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
2748 end Is_Actual_Parameter
;
2750 ---------------------
2751 -- Is_Aliased_View --
2752 ---------------------
2754 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
2758 if Is_Entity_Name
(Obj
) then
2760 -- Shouldn't we check that we really have an object here?
2761 -- If we do, then a-caldel.adb blows up mysteriously ???
2765 return Is_Aliased
(E
)
2766 or else (Present
(Renamed_Object
(E
))
2767 and then Is_Aliased_View
(Renamed_Object
(E
)))
2769 or else ((Is_Formal
(E
)
2770 or else Ekind
(E
) = E_Generic_In_Out_Parameter
2771 or else Ekind
(E
) = E_Generic_In_Parameter
)
2772 and then Is_Tagged_Type
(Etype
(E
)))
2774 or else ((Ekind
(E
) = E_Task_Type
or else
2775 Ekind
(E
) = E_Protected_Type
)
2776 and then In_Open_Scopes
(E
))
2778 -- Current instance of type
2780 or else (Is_Type
(E
) and then E
= Current_Scope
)
2781 or else (Is_Incomplete_Or_Private_Type
(E
)
2782 and then Full_View
(E
) = Current_Scope
);
2784 elsif Nkind
(Obj
) = N_Selected_Component
then
2785 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
2787 elsif Nkind
(Obj
) = N_Indexed_Component
then
2788 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
2790 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
2792 Has_Aliased_Components
2793 (Designated_Type
(Etype
(Prefix
(Obj
)))));
2795 elsif Nkind
(Obj
) = N_Unchecked_Type_Conversion
2796 or else Nkind
(Obj
) = N_Type_Conversion
2798 return Is_Tagged_Type
(Etype
(Obj
))
2799 or else Is_Aliased_View
(Expression
(Obj
));
2801 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
2802 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
2807 end Is_Aliased_View
;
2809 ----------------------
2810 -- Is_Atomic_Object --
2811 ----------------------
2813 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
2815 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean;
2816 -- Determines if given object has atomic components
2818 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean;
2819 -- If prefix is an implicit dereference, examine designated type.
2821 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean is
2823 if Is_Access_Type
(Etype
(N
)) then
2825 Has_Atomic_Components
(Designated_Type
(Etype
(N
)));
2827 return Object_Has_Atomic_Components
(N
);
2829 end Is_Atomic_Prefix
;
2831 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean is
2833 if Has_Atomic_Components
(Etype
(N
))
2834 or else Is_Atomic
(Etype
(N
))
2838 elsif Is_Entity_Name
(N
)
2839 and then (Has_Atomic_Components
(Entity
(N
))
2840 or else Is_Atomic
(Entity
(N
)))
2844 elsif Nkind
(N
) = N_Indexed_Component
2845 or else Nkind
(N
) = N_Selected_Component
2847 return Is_Atomic_Prefix
(Prefix
(N
));
2852 end Object_Has_Atomic_Components
;
2854 -- Start of processing for Is_Atomic_Object
2857 if Is_Atomic
(Etype
(N
))
2858 or else (Is_Entity_Name
(N
) and then Is_Atomic
(Entity
(N
)))
2862 elsif Nkind
(N
) = N_Indexed_Component
2863 or else Nkind
(N
) = N_Selected_Component
2865 return Is_Atomic_Prefix
(Prefix
(N
));
2870 end Is_Atomic_Object
;
2872 ----------------------------------------------
2873 -- Is_Dependent_Component_Of_Mutable_Object --
2874 ----------------------------------------------
2876 function Is_Dependent_Component_Of_Mutable_Object
2881 Prefix_Type
: Entity_Id
;
2882 P_Aliased
: Boolean := False;
2885 function Has_Dependent_Constraint
(Comp
: Entity_Id
) return Boolean;
2886 -- Returns True if and only if Comp has a constrained subtype
2887 -- that depends on a discriminant.
2889 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean;
2890 -- Returns True if and only if Comp is declared within a variant part.
2892 ------------------------------
2893 -- Has_Dependent_Constraint --
2894 ------------------------------
2896 function Has_Dependent_Constraint
(Comp
: Entity_Id
) return Boolean is
2897 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
2898 Subt_Indic
: constant Node_Id
:= Subtype_Indication
(Comp_Decl
);
2903 if Nkind
(Subt_Indic
) = N_Subtype_Indication
then
2904 Constr
:= Constraint
(Subt_Indic
);
2906 if Nkind
(Constr
) = N_Index_Or_Discriminant_Constraint
then
2907 Assn
:= First
(Constraints
(Constr
));
2908 while Present
(Assn
) loop
2909 case Nkind
(Assn
) is
2910 when N_Subtype_Indication |
2914 if Depends_On_Discriminant
(Assn
) then
2918 when N_Discriminant_Association
=>
2919 if Depends_On_Discriminant
(Expression
(Assn
)) then
2934 end Has_Dependent_Constraint
;
2936 --------------------------------
2937 -- Is_Declared_Within_Variant --
2938 --------------------------------
2940 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
2941 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
2942 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
2945 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
2946 end Is_Declared_Within_Variant
;
2948 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
2951 if Is_Variable
(Object
) then
2953 if Nkind
(Object
) = N_Selected_Component
then
2954 P
:= Prefix
(Object
);
2955 Prefix_Type
:= Etype
(P
);
2957 if Is_Entity_Name
(P
) then
2959 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
2960 Prefix_Type
:= Base_Type
(Prefix_Type
);
2963 if Is_Aliased
(Entity
(P
)) then
2968 -- Check for prefix being an aliased component ???
2972 if Is_Access_Type
(Prefix_Type
)
2973 or else Nkind
(P
) = N_Explicit_Dereference
2979 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
2981 -- As per AI-0017, the renaming is illegal in a generic body,
2982 -- even if the subtype is indefinite.
2984 if not Is_Constrained
(Prefix_Type
)
2985 and then (not Is_Indefinite_Subtype
(Prefix_Type
)
2987 (Is_Generic_Type
(Prefix_Type
)
2988 and then Ekind
(Current_Scope
) = E_Generic_Package
2989 and then In_Package_Body
(Current_Scope
)))
2991 and then (Is_Declared_Within_Variant
(Comp
)
2992 or else Has_Dependent_Constraint
(Comp
))
2993 and then not P_Aliased
2999 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
3003 elsif Nkind
(Object
) = N_Indexed_Component
3004 or else Nkind
(Object
) = N_Slice
3006 return Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
3011 end Is_Dependent_Component_Of_Mutable_Object
;
3017 function Is_False
(U
: Uint
) return Boolean is
3022 ---------------------------
3023 -- Is_Fixed_Model_Number --
3024 ---------------------------
3026 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
3027 S
: constant Ureal
:= Small_Value
(T
);
3028 M
: Urealp
.Save_Mark
;
3033 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
3036 end Is_Fixed_Model_Number
;
3038 -------------------------------
3039 -- Is_Fully_Initialized_Type --
3040 -------------------------------
3042 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
3044 if Is_Scalar_Type
(Typ
) then
3047 elsif Is_Access_Type
(Typ
) then
3050 elsif Is_Array_Type
(Typ
) then
3051 if Is_Fully_Initialized_Type
(Component_Type
(Typ
)) then
3055 -- An interesting case, if we have a constrained type one of whose
3056 -- bounds is known to be null, then there are no elements to be
3057 -- initialized, so all the elements are initialized!
3059 if Is_Constrained
(Typ
) then
3062 Indx_Typ
: Entity_Id
;
3066 Indx
:= First_Index
(Typ
);
3067 while Present
(Indx
) loop
3069 if Etype
(Indx
) = Any_Type
then
3072 -- If index is a range, use directly.
3074 elsif Nkind
(Indx
) = N_Range
then
3075 Lbd
:= Low_Bound
(Indx
);
3076 Hbd
:= High_Bound
(Indx
);
3079 Indx_Typ
:= Etype
(Indx
);
3081 if Is_Private_Type
(Indx_Typ
) then
3082 Indx_Typ
:= Full_View
(Indx_Typ
);
3085 if No
(Indx_Typ
) then
3088 Lbd
:= Type_Low_Bound
(Indx_Typ
);
3089 Hbd
:= Type_High_Bound
(Indx_Typ
);
3093 if Compile_Time_Known_Value
(Lbd
)
3094 and then Compile_Time_Known_Value
(Hbd
)
3096 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
3106 -- If no null indexes, then type is not fully initialized
3110 elsif Is_Record_Type
(Typ
) then
3115 Ent
:= First_Entity
(Typ
);
3117 while Present
(Ent
) loop
3118 if Ekind
(Ent
) = E_Component
3119 and then (No
(Parent
(Ent
))
3120 or else No
(Expression
(Parent
(Ent
))))
3121 and then not Is_Fully_Initialized_Type
(Etype
(Ent
))
3130 -- No uninitialized components, so type is fully initialized.
3131 -- Note that this catches the case of no components as well.
3135 elsif Is_Concurrent_Type
(Typ
) then
3138 elsif Is_Private_Type
(Typ
) then
3140 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
3146 return Is_Fully_Initialized_Type
(U
);
3153 end Is_Fully_Initialized_Type
;
3155 ----------------------------
3156 -- Is_Inherited_Operation --
3157 ----------------------------
3159 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
3160 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
3163 pragma Assert
(Is_Overloadable
(E
));
3164 return Kind
= N_Full_Type_Declaration
3165 or else Kind
= N_Private_Extension_Declaration
3166 or else Kind
= N_Subtype_Declaration
3167 or else (Ekind
(E
) = E_Enumeration_Literal
3168 and then Is_Derived_Type
(Etype
(E
)));
3169 end Is_Inherited_Operation
;
3171 -----------------------------
3172 -- Is_Library_Level_Entity --
3173 -----------------------------
3175 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
3177 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
3178 end Is_Library_Level_Entity
;
3180 ---------------------------------
3181 -- Is_Local_Variable_Reference --
3182 ---------------------------------
3184 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
3186 if not Is_Entity_Name
(Expr
) then
3191 Ent
: constant Entity_Id
:= Entity
(Expr
);
3192 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
3195 if Ekind
(Ent
) /= E_Variable
3197 Ekind
(Ent
) /= E_In_Out_Parameter
3202 return Present
(Sub
) and then Sub
= Current_Subprogram
;
3206 end Is_Local_Variable_Reference
;
3208 -------------------------
3209 -- Is_Object_Reference --
3210 -------------------------
3212 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
3214 if Is_Entity_Name
(N
) then
3215 return Is_Object
(Entity
(N
));
3219 when N_Indexed_Component | N_Slice
=>
3220 return Is_Object_Reference
(Prefix
(N
));
3222 -- In Ada95, a function call is a constant object.
3224 when N_Function_Call
=>
3227 -- A reference to the stream attribute Input is a function call.
3229 when N_Attribute_Reference
=>
3230 return Attribute_Name
(N
) = Name_Input
;
3232 when N_Selected_Component
=>
3233 return Is_Object_Reference
(Selector_Name
(N
));
3235 when N_Explicit_Dereference
=>
3238 -- An unchecked type conversion is considered to be an object if
3239 -- the operand is an object (this construction arises only as a
3240 -- result of expansion activities).
3242 when N_Unchecked_Type_Conversion
=>
3249 end Is_Object_Reference
;
3251 -----------------------------------
3252 -- Is_OK_Variable_For_Out_Formal --
3253 -----------------------------------
3255 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
3257 Note_Possible_Modification
(AV
);
3259 -- We must reject parenthesized variable names. The check for
3260 -- Comes_From_Source is present because there are currently
3261 -- cases where the compiler violates this rule (e.g. passing
3262 -- a task object to its controlled Initialize routine).
3264 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
3267 -- A variable is always allowed
3269 elsif Is_Variable
(AV
) then
3272 -- Unchecked conversions are allowed only if they come from the
3273 -- generated code, which sometimes uses unchecked conversions for
3274 -- out parameters in cases where code generation is unaffected.
3275 -- We tell source unchecked conversions by seeing if they are
3276 -- rewrites of an original UC function call, or of an explicit
3277 -- conversion of a function call.
3279 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
3280 if Nkind
(Original_Node
(AV
)) = N_Function_Call
then
3283 elsif Comes_From_Source
(AV
)
3284 and then Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
3292 -- Normal type conversions are allowed if argument is a variable
3294 elsif Nkind
(AV
) = N_Type_Conversion
then
3295 if Is_Variable
(Expression
(AV
))
3296 and then Paren_Count
(Expression
(AV
)) = 0
3298 Note_Possible_Modification
(Expression
(AV
));
3301 -- We also allow a non-parenthesized expression that raises
3302 -- constraint error if it rewrites what used to be a variable
3304 elsif Raises_Constraint_Error
(Expression
(AV
))
3305 and then Paren_Count
(Expression
(AV
)) = 0
3306 and then Is_Variable
(Original_Node
(Expression
(AV
)))
3310 -- Type conversion of something other than a variable
3316 -- If this node is rewritten, then test the original form, if that is
3317 -- OK, then we consider the rewritten node OK (for example, if the
3318 -- original node is a conversion, then Is_Variable will not be true
3319 -- but we still want to allow the conversion if it converts a variable.
3321 elsif Original_Node
(AV
) /= AV
then
3322 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
3324 -- All other non-variables are rejected
3329 end Is_OK_Variable_For_Out_Formal
;
3331 -----------------------------------
3332 -- Is_Partially_Initialized_Type --
3333 -----------------------------------
3335 function Is_Partially_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
3337 if Is_Scalar_Type
(Typ
) then
3340 elsif Is_Access_Type
(Typ
) then
3343 elsif Is_Array_Type
(Typ
) then
3345 -- If component type is partially initialized, so is array type
3347 if Is_Partially_Initialized_Type
(Component_Type
(Typ
)) then
3350 -- Otherwise we are only partially initialized if we are fully
3351 -- initialized (this is the empty array case, no point in us
3352 -- duplicating that code here).
3355 return Is_Fully_Initialized_Type
(Typ
);
3358 elsif Is_Record_Type
(Typ
) then
3360 -- A discriminated type is always partially initialized
3362 if Has_Discriminants
(Typ
) then
3365 -- A tagged type is always partially initialized
3367 elsif Is_Tagged_Type
(Typ
) then
3370 -- Case of non-discriminated record
3376 Component_Present
: Boolean := False;
3377 -- Set True if at least one component is present. If no
3378 -- components are present, then record type is fully
3379 -- initialized (another odd case, like the null array).
3382 -- Loop through components
3384 Ent
:= First_Entity
(Typ
);
3385 while Present
(Ent
) loop
3386 if Ekind
(Ent
) = E_Component
then
3387 Component_Present
:= True;
3389 -- If a component has an initialization expression then
3390 -- the enclosing record type is partially initialized
3392 if Present
(Parent
(Ent
))
3393 and then Present
(Expression
(Parent
(Ent
)))
3397 -- If a component is of a type which is itself partially
3398 -- initialized, then the enclosing record type is also.
3400 elsif Is_Partially_Initialized_Type
(Etype
(Ent
)) then
3408 -- No initialized components found. If we found any components
3409 -- they were all uninitialized so the result is false.
3411 if Component_Present
then
3414 -- But if we found no components, then all the components are
3415 -- initialized so we consider the type to be initialized.
3423 -- Concurrent types are always fully initialized
3425 elsif Is_Concurrent_Type
(Typ
) then
3428 -- For a private type, go to underlying type. If there is no underlying
3429 -- type then just assume this partially initialized. Not clear if this
3430 -- can happen in a non-error case, but no harm in testing for this.
3432 elsif Is_Private_Type
(Typ
) then
3434 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
3440 return Is_Partially_Initialized_Type
(U
);
3444 -- For any other type (are there any?) assume partially initialized
3449 end Is_Partially_Initialized_Type
;
3451 -----------------------------
3452 -- Is_RCI_Pkg_Spec_Or_Body --
3453 -----------------------------
3455 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
3457 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
3458 -- Return True if the unit of Cunit is an RCI package declaration
3460 ---------------------------
3461 -- Is_RCI_Pkg_Decl_Cunit --
3462 ---------------------------
3464 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
3465 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
3468 if Nkind
(The_Unit
) /= N_Package_Declaration
then
3471 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
3472 end Is_RCI_Pkg_Decl_Cunit
;
3474 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
3477 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
3479 (Nkind
(Unit
(Cunit
)) = N_Package_Body
3480 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
3481 end Is_RCI_Pkg_Spec_Or_Body
;
3483 -----------------------------------------
3484 -- Is_Remote_Access_To_Class_Wide_Type --
3485 -----------------------------------------
3487 function Is_Remote_Access_To_Class_Wide_Type
3493 function Comes_From_Limited_Private_Type_Declaration
3496 -- Check if the original declaration is a limited private one and
3497 -- if all the derivations have been using private extensions.
3499 -------------------------------------------------
3500 -- Comes_From_Limited_Private_Type_Declaration --
3501 -------------------------------------------------
3503 function Comes_From_Limited_Private_Type_Declaration
(E
: in Entity_Id
)
3506 N
: constant Node_Id
:= Declaration_Node
(E
);
3508 if Nkind
(N
) = N_Private_Type_Declaration
3509 and then Limited_Present
(N
)
3514 if Nkind
(N
) = N_Private_Extension_Declaration
then
3515 return Comes_From_Limited_Private_Type_Declaration
(Etype
(E
));
3519 end Comes_From_Limited_Private_Type_Declaration
;
3521 -- Start of processing for Is_Remote_Access_To_Class_Wide_Type
3524 if not (Is_Remote_Call_Interface
(E
)
3525 or else Is_Remote_Types
(E
))
3526 or else Ekind
(E
) /= E_General_Access_Type
3531 D
:= Designated_Type
(E
);
3533 if Ekind
(D
) /= E_Class_Wide_Type
then
3537 return Comes_From_Limited_Private_Type_Declaration
3538 (Defining_Identifier
(Parent
(D
)));
3539 end Is_Remote_Access_To_Class_Wide_Type
;
3541 -----------------------------------------
3542 -- Is_Remote_Access_To_Subprogram_Type --
3543 -----------------------------------------
3545 function Is_Remote_Access_To_Subprogram_Type
3550 return (Ekind
(E
) = E_Access_Subprogram_Type
3551 or else (Ekind
(E
) = E_Record_Type
3552 and then Present
(Corresponding_Remote_Type
(E
))))
3553 and then (Is_Remote_Call_Interface
(E
)
3554 or else Is_Remote_Types
(E
));
3555 end Is_Remote_Access_To_Subprogram_Type
;
3557 --------------------
3558 -- Is_Remote_Call --
3559 --------------------
3561 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
3563 if Nkind
(N
) /= N_Procedure_Call_Statement
3564 and then Nkind
(N
) /= N_Function_Call
3566 -- An entry call cannot be remote
3570 elsif Nkind
(Name
(N
)) in N_Has_Entity
3571 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
3573 -- A subprogram declared in the spec of a RCI package is remote
3577 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
3578 and then Is_Remote_Access_To_Subprogram_Type
3579 (Etype
(Prefix
(Name
(N
))))
3581 -- The dereference of a RAS is a remote call
3585 elsif Present
(Controlling_Argument
(N
))
3586 and then Is_Remote_Access_To_Class_Wide_Type
3587 (Etype
(Controlling_Argument
(N
)))
3589 -- Any primitive operation call with a controlling argument of
3590 -- a RACW type is a remote call.
3595 -- All other calls are local calls
3600 ----------------------
3601 -- Is_Selector_Name --
3602 ----------------------
3604 function Is_Selector_Name
(N
: Node_Id
) return Boolean is
3607 if not Is_List_Member
(N
) then
3609 P
: constant Node_Id
:= Parent
(N
);
3610 K
: constant Node_Kind
:= Nkind
(P
);
3614 (K
= N_Expanded_Name
or else
3615 K
= N_Generic_Association
or else
3616 K
= N_Parameter_Association
or else
3617 K
= N_Selected_Component
)
3618 and then Selector_Name
(P
) = N
;
3623 L
: constant List_Id
:= List_Containing
(N
);
3624 P
: constant Node_Id
:= Parent
(L
);
3627 return (Nkind
(P
) = N_Discriminant_Association
3628 and then Selector_Names
(P
) = L
)
3630 (Nkind
(P
) = N_Component_Association
3631 and then Choices
(P
) = L
);
3634 end Is_Selector_Name
;
3640 function Is_Statement
(N
: Node_Id
) return Boolean is
3643 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
3644 or else Nkind
(N
) = N_Procedure_Call_Statement
;
3651 function Is_Transfer
(N
: Node_Id
) return Boolean is
3652 Kind
: constant Node_Kind
:= Nkind
(N
);
3655 if Kind
= N_Return_Statement
3657 Kind
= N_Goto_Statement
3659 Kind
= N_Raise_Statement
3661 Kind
= N_Requeue_Statement
3665 elsif (Kind
= N_Exit_Statement
or else Kind
in N_Raise_xxx_Error
)
3666 and then No
(Condition
(N
))
3670 elsif Kind
= N_Procedure_Call_Statement
3671 and then Is_Entity_Name
(Name
(N
))
3672 and then Present
(Entity
(Name
(N
)))
3673 and then No_Return
(Entity
(Name
(N
)))
3677 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
3689 function Is_True
(U
: Uint
) return Boolean is
3698 function Is_Variable
(N
: Node_Id
) return Boolean is
3700 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
3701 -- We do the test on the original node, since this is basically a
3702 -- test of syntactic categories, so it must not be disturbed by
3703 -- whatever rewriting might have occurred. For example, an aggregate,
3704 -- which is certainly NOT a variable, could be turned into a variable
3707 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
3708 -- Within a protected function, the private components of the
3709 -- enclosing protected type are constants. A function nested within
3710 -- a (protected) procedure is not itself protected.
3712 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
3713 -- Prefixes can involve implicit dereferences, in which case we
3714 -- must test for the case of a reference of a constant access
3715 -- type, which can never be a variable.
3717 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
3718 Prot
: constant Entity_Id
:= Scope
(E
);
3722 if not Is_Protected_Type
(Prot
) then
3727 while Present
(S
) and then S
/= Prot
loop
3729 if Ekind
(S
) = E_Function
3730 and then Scope
(S
) = Prot
3740 end In_Protected_Function
;
3742 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
3744 if Is_Access_Type
(Etype
(P
)) then
3745 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
3747 return Is_Variable
(P
);
3749 end Is_Variable_Prefix
;
3751 -- Start of processing for Is_Variable
3754 -- Definitely OK if Assignment_OK is set. Since this is something that
3755 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
3757 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
3760 -- Normally we go to the original node, but there is one exception
3761 -- where we use the rewritten node, namely when it is an explicit
3762 -- dereference. The generated code may rewrite a prefix which is an
3763 -- access type with an explicit dereference. The dereference is a
3764 -- variable, even though the original node may not be (since it could
3765 -- be a constant of the access type).
3767 elsif Nkind
(N
) = N_Explicit_Dereference
3768 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
3769 and then Is_Access_Type
(Etype
(Orig_Node
))
3771 return Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
3773 -- All remaining checks use the original node
3775 elsif Is_Entity_Name
(Orig_Node
) then
3777 E
: constant Entity_Id
:= Entity
(Orig_Node
);
3778 K
: constant Entity_Kind
:= Ekind
(E
);
3781 return (K
= E_Variable
3782 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
3783 or else (K
= E_Component
3784 and then not In_Protected_Function
(E
))
3785 or else K
= E_Out_Parameter
3786 or else K
= E_In_Out_Parameter
3787 or else K
= E_Generic_In_Out_Parameter
3789 -- Current instance of type:
3791 or else (Is_Type
(E
) and then In_Open_Scopes
(E
))
3792 or else (Is_Incomplete_Or_Private_Type
(E
)
3793 and then In_Open_Scopes
(Full_View
(E
)));
3797 case Nkind
(Orig_Node
) is
3798 when N_Indexed_Component | N_Slice
=>
3799 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
3801 when N_Selected_Component
=>
3802 return Is_Variable_Prefix
(Prefix
(Orig_Node
))
3803 and then Is_Variable
(Selector_Name
(Orig_Node
));
3805 -- For an explicit dereference, we must check whether the type
3806 -- is ACCESS CONSTANT, since if it is, then it is not a variable.
3808 when N_Explicit_Dereference
=>
3809 return Is_Access_Type
(Etype
(Prefix
(Orig_Node
)))
3811 Is_Access_Constant
(Root_Type
(Etype
(Prefix
(Orig_Node
))));
3813 -- The type conversion is the case where we do not deal with the
3814 -- context dependent special case of an actual parameter. Thus
3815 -- the type conversion is only considered a variable for the
3816 -- purposes of this routine if the target type is tagged. However,
3817 -- a type conversion is considered to be a variable if it does not
3818 -- come from source (this deals for example with the conversions
3819 -- of expressions to their actual subtypes).
3821 when N_Type_Conversion
=>
3822 return Is_Variable
(Expression
(Orig_Node
))
3824 (not Comes_From_Source
(Orig_Node
)
3826 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
3828 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
3830 -- GNAT allows an unchecked type conversion as a variable. This
3831 -- only affects the generation of internal expanded code, since
3832 -- calls to instantiations of Unchecked_Conversion are never
3833 -- considered variables (since they are function calls).
3834 -- This is also true for expression actions.
3836 when N_Unchecked_Type_Conversion
=>
3837 return Is_Variable
(Expression
(Orig_Node
));
3845 ------------------------
3846 -- Is_Volatile_Object --
3847 ------------------------
3849 function Is_Volatile_Object
(N
: Node_Id
) return Boolean is
3851 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean;
3852 -- Determines if given object has volatile components
3854 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean;
3855 -- If prefix is an implicit dereference, examine designated type.
3857 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean is
3859 if Is_Access_Type
(Etype
(N
)) then
3860 return Has_Volatile_Components
(Designated_Type
(Etype
(N
)));
3862 return Object_Has_Volatile_Components
(N
);
3864 end Is_Volatile_Prefix
;
3866 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean is
3868 if Is_Volatile
(Etype
(N
))
3869 or else Has_Volatile_Components
(Etype
(N
))
3873 elsif Is_Entity_Name
(N
)
3874 and then (Has_Volatile_Components
(Entity
(N
))
3875 or else Is_Volatile
(Entity
(N
)))
3879 elsif Nkind
(N
) = N_Indexed_Component
3880 or else Nkind
(N
) = N_Selected_Component
3882 return Is_Volatile_Prefix
(Prefix
(N
));
3887 end Object_Has_Volatile_Components
;
3889 -- Start of processing for Is_Volatile_Object
3892 if Is_Volatile
(Etype
(N
))
3893 or else (Is_Entity_Name
(N
) and then Is_Volatile
(Entity
(N
)))
3897 elsif Nkind
(N
) = N_Indexed_Component
3898 or else Nkind
(N
) = N_Selected_Component
3900 return Is_Volatile_Prefix
(Prefix
(N
));
3905 end Is_Volatile_Object
;
3907 --------------------------
3908 -- Kill_Size_Check_Code --
3909 --------------------------
3911 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
3913 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
3914 and then Present
(Size_Check_Code
(E
))
3916 Remove
(Size_Check_Code
(E
));
3917 Set_Size_Check_Code
(E
, Empty
);
3919 end Kill_Size_Check_Code
;
3921 -------------------------
3922 -- New_External_Entity --
3923 -------------------------
3925 function New_External_Entity
3926 (Kind
: Entity_Kind
;
3927 Scope_Id
: Entity_Id
;
3928 Sloc_Value
: Source_Ptr
;
3929 Related_Id
: Entity_Id
;
3931 Suffix_Index
: Nat
:= 0;
3932 Prefix
: Character := ' ')
3935 N
: constant Entity_Id
:=
3936 Make_Defining_Identifier
(Sloc_Value
,
3938 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
3941 Set_Ekind
(N
, Kind
);
3942 Set_Is_Internal
(N
, True);
3943 Append_Entity
(N
, Scope_Id
);
3944 Set_Public_Status
(N
);
3946 if Kind
in Type_Kind
then
3947 Init_Size_Align
(N
);
3951 end New_External_Entity
;
3953 -------------------------
3954 -- New_Internal_Entity --
3955 -------------------------
3957 function New_Internal_Entity
3958 (Kind
: Entity_Kind
;
3959 Scope_Id
: Entity_Id
;
3960 Sloc_Value
: Source_Ptr
;
3961 Id_Char
: Character)
3964 N
: constant Entity_Id
:=
3965 Make_Defining_Identifier
(Sloc_Value
, New_Internal_Name
(Id_Char
));
3968 Set_Ekind
(N
, Kind
);
3969 Set_Is_Internal
(N
, True);
3970 Append_Entity
(N
, Scope_Id
);
3972 if Kind
in Type_Kind
then
3973 Init_Size_Align
(N
);
3977 end New_Internal_Entity
;
3983 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
3987 -- If we are pointing at a positional parameter, it is a member of
3988 -- a node list (the list of parameters), and the next parameter
3989 -- is the next node on the list, unless we hit a parameter
3990 -- association, in which case we shift to using the chain whose
3991 -- head is the First_Named_Actual in the parent, and then is
3992 -- threaded using the Next_Named_Actual of the Parameter_Association.
3993 -- All this fiddling is because the original node list is in the
3994 -- textual call order, and what we need is the declaration order.
3996 if Is_List_Member
(Actual_Id
) then
3997 N
:= Next
(Actual_Id
);
3999 if Nkind
(N
) = N_Parameter_Association
then
4000 return First_Named_Actual
(Parent
(Actual_Id
));
4006 return Next_Named_Actual
(Parent
(Actual_Id
));
4010 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
4012 Actual_Id
:= Next_Actual
(Actual_Id
);
4015 -----------------------
4016 -- Normalize_Actuals --
4017 -----------------------
4019 -- Chain actuals according to formals of subprogram. If there are
4020 -- no named associations, the chain is simply the list of Parameter
4021 -- Associations, since the order is the same as the declaration order.
4022 -- If there are named associations, then the First_Named_Actual field
4023 -- in the N_Procedure_Call_Statement node or N_Function_Call node
4024 -- points to the Parameter_Association node for the parameter that
4025 -- comes first in declaration order. The remaining named parameters
4026 -- are then chained in declaration order using Next_Named_Actual.
4028 -- This routine also verifies that the number of actuals is compatible
4029 -- with the number and default values of formals, but performs no type
4030 -- checking (type checking is done by the caller).
4032 -- If the matching succeeds, Success is set to True, and the caller
4033 -- proceeds with type-checking. If the match is unsuccessful, then
4034 -- Success is set to False, and the caller attempts a different
4035 -- interpretation, if there is one.
4037 -- If the flag Report is on, the call is not overloaded, and a failure
4038 -- to match can be reported here, rather than in the caller.
4040 procedure Normalize_Actuals
4044 Success
: out Boolean)
4046 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
4047 Actual
: Node_Id
:= Empty
;
4049 Last
: Node_Id
:= Empty
;
4050 First_Named
: Node_Id
:= Empty
;
4053 Formals_To_Match
: Integer := 0;
4054 Actuals_To_Match
: Integer := 0;
4056 procedure Chain
(A
: Node_Id
);
4057 -- Add named actual at the proper place in the list, using the
4058 -- Next_Named_Actual link.
4060 function Reporting
return Boolean;
4061 -- Determines if an error is to be reported. To report an error, we
4062 -- need Report to be True, and also we do not report errors caused
4063 -- by calls to Init_Proc's that occur within other Init_Proc's. Such
4064 -- errors must always be cascaded errors, since if all the types are
4065 -- declared correctly, the compiler will certainly build decent calls!
4067 procedure Chain
(A
: Node_Id
) is
4071 -- Call node points to first actual in list.
4073 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
4076 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
4080 Set_Next_Named_Actual
(Last
, Empty
);
4083 function Reporting
return Boolean is
4088 elsif not Within_Init_Proc
then
4091 elsif Chars
(Entity
(Name
(N
))) = Name_uInit_Proc
then
4099 -- Start of processing for Normalize_Actuals
4102 if Is_Access_Type
(S
) then
4104 -- The name in the call is a function call that returns an access
4105 -- to subprogram. The designated type has the list of formals.
4107 Formal
:= First_Formal
(Designated_Type
(S
));
4109 Formal
:= First_Formal
(S
);
4112 while Present
(Formal
) loop
4113 Formals_To_Match
:= Formals_To_Match
+ 1;
4114 Next_Formal
(Formal
);
4117 -- Find if there is a named association, and verify that no positional
4118 -- associations appear after named ones.
4120 if Present
(Actuals
) then
4121 Actual
:= First
(Actuals
);
4124 while Present
(Actual
)
4125 and then Nkind
(Actual
) /= N_Parameter_Association
4127 Actuals_To_Match
:= Actuals_To_Match
+ 1;
4131 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
4133 -- Most common case: positional notation, no defaults
4138 elsif Actuals_To_Match
> Formals_To_Match
then
4140 -- Too many actuals: will not work.
4143 Error_Msg_N
("too many arguments in call", N
);
4150 First_Named
:= Actual
;
4152 while Present
(Actual
) loop
4153 if Nkind
(Actual
) /= N_Parameter_Association
then
4155 ("positional parameters not allowed after named ones", Actual
);
4160 Actuals_To_Match
:= Actuals_To_Match
+ 1;
4166 if Present
(Actuals
) then
4167 Actual
:= First
(Actuals
);
4170 Formal
:= First_Formal
(S
);
4172 while Present
(Formal
) loop
4174 -- Match the formals in order. If the corresponding actual
4175 -- is positional, nothing to do. Else scan the list of named
4176 -- actuals to find the one with the right name.
4179 and then Nkind
(Actual
) /= N_Parameter_Association
4182 Actuals_To_Match
:= Actuals_To_Match
- 1;
4183 Formals_To_Match
:= Formals_To_Match
- 1;
4186 -- For named parameters, search the list of actuals to find
4187 -- one that matches the next formal name.
4189 Actual
:= First_Named
;
4192 while Present
(Actual
) loop
4193 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
4196 Actuals_To_Match
:= Actuals_To_Match
- 1;
4197 Formals_To_Match
:= Formals_To_Match
- 1;
4205 if Ekind
(Formal
) /= E_In_Parameter
4206 or else No
(Default_Value
(Formal
))
4209 if Comes_From_Source
(S
)
4210 and then Is_Overloadable
(S
)
4212 Error_Msg_Name_1
:= Chars
(S
);
4213 Error_Msg_Sloc
:= Sloc
(S
);
4215 ("missing argument for parameter & " &
4216 "in call to % declared #", N
, Formal
);
4219 ("missing argument for parameter &", N
, Formal
);
4227 Formals_To_Match
:= Formals_To_Match
- 1;
4232 Next_Formal
(Formal
);
4235 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
4242 -- Find some superfluous named actual that did not get
4243 -- attached to the list of associations.
4245 Actual
:= First
(Actuals
);
4247 while Present
(Actual
) loop
4249 if Nkind
(Actual
) = N_Parameter_Association
4250 and then Actual
/= Last
4251 and then No
(Next_Named_Actual
(Actual
))
4253 Error_Msg_N
("Unmatched actual in call", Actual
);
4264 end Normalize_Actuals
;
4266 --------------------------------
4267 -- Note_Possible_Modification --
4268 --------------------------------
4270 procedure Note_Possible_Modification
(N
: Node_Id
) is
4274 procedure Set_Ref
(E
: Entity_Id
; N
: Node_Id
);
4275 -- Internal routine to note modification on entity E by node N
4277 procedure Set_Ref
(E
: Entity_Id
; N
: Node_Id
) is
4279 Set_Not_Source_Assigned
(E
, False);
4280 Set_Is_True_Constant
(E
, False);
4281 Generate_Reference
(E
, N
, 'm');
4284 -- Start of processing for Note_Possible_Modification
4287 -- Loop to find referenced entity, if there is one
4291 -- Test for node rewritten as dereference (e.g. accept parameter)
4293 if Nkind
(Exp
) = N_Explicit_Dereference
4294 and then Is_Entity_Name
(Original_Node
(Exp
))
4296 Set_Ref
(Entity
(Original_Node
(Exp
)), Original_Node
(Exp
));
4299 elsif Is_Entity_Name
(Exp
) then
4300 Ent
:= Entity
(Exp
);
4302 if (Ekind
(Ent
) = E_Variable
or else Ekind
(Ent
) = E_Constant
)
4303 and then Present
(Renamed_Object
(Ent
))
4305 Exp
:= Renamed_Object
(Ent
);
4312 elsif Nkind
(Exp
) = N_Type_Conversion
4313 or else Nkind
(Exp
) = N_Unchecked_Type_Conversion
4315 Exp
:= Expression
(Exp
);
4317 elsif Nkind
(Exp
) = N_Slice
4318 or else Nkind
(Exp
) = N_Indexed_Component
4319 or else Nkind
(Exp
) = N_Selected_Component
4321 Exp
:= Prefix
(Exp
);
4327 end Note_Possible_Modification
;
4329 -------------------------
4330 -- Object_Access_Level --
4331 -------------------------
4333 function Object_Access_Level
(Obj
: Node_Id
) return Uint
is
4336 -- Returns the static accessibility level of the view denoted
4337 -- by Obj. Note that the value returned is the result of a
4338 -- call to Scope_Depth. Only scope depths associated with
4339 -- dynamic scopes can actually be returned. Since only
4340 -- relative levels matter for accessibility checking, the fact
4341 -- that the distance between successive levels of accessibility
4342 -- is not always one is immaterial (invariant: if level(E2) is
4343 -- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
4346 if Is_Entity_Name
(Obj
) then
4349 -- If E is a type then it denotes a current instance.
4350 -- For this case we add one to the normal accessibility
4351 -- level of the type to ensure that current instances
4352 -- are treated as always being deeper than than the level
4353 -- of any visible named access type (see 3.10.2(21)).
4356 return Type_Access_Level
(E
) + 1;
4358 elsif Present
(Renamed_Object
(E
)) then
4359 return Object_Access_Level
(Renamed_Object
(E
));
4361 -- Similarly, if E is a component of the current instance of a
4362 -- protected type, any instance of it is assumed to be at a deeper
4363 -- level than the type. For a protected object (whose type is an
4364 -- anonymous protected type) its components are at the same level
4365 -- as the type itself.
4367 elsif not Is_Overloadable
(E
)
4368 and then Ekind
(Scope
(E
)) = E_Protected_Type
4369 and then Comes_From_Source
(Scope
(E
))
4371 return Type_Access_Level
(Scope
(E
)) + 1;
4374 return Scope_Depth
(Enclosing_Dynamic_Scope
(E
));
4377 elsif Nkind
(Obj
) = N_Selected_Component
then
4378 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
4379 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
4381 return Object_Access_Level
(Prefix
(Obj
));
4384 elsif Nkind
(Obj
) = N_Indexed_Component
then
4385 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
4386 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
4388 return Object_Access_Level
(Prefix
(Obj
));
4391 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
4393 -- If the prefix is a selected access discriminant then
4394 -- we make a recursive call on the prefix, which will
4395 -- in turn check the level of the prefix object of
4396 -- the selected discriminant.
4398 if Nkind
(Prefix
(Obj
)) = N_Selected_Component
4399 and then Ekind
(Etype
(Prefix
(Obj
))) = E_Anonymous_Access_Type
4401 Ekind
(Entity
(Selector_Name
(Prefix
(Obj
)))) = E_Discriminant
4403 return Object_Access_Level
(Prefix
(Obj
));
4405 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
4408 elsif Nkind
(Obj
) = N_Type_Conversion
then
4409 return Object_Access_Level
(Expression
(Obj
));
4411 -- Function results are objects, so we get either the access level
4412 -- of the function or, in the case of an indirect call, the level of
4413 -- of the access-to-subprogram type.
4415 elsif Nkind
(Obj
) = N_Function_Call
then
4416 if Is_Entity_Name
(Name
(Obj
)) then
4417 return Subprogram_Access_Level
(Entity
(Name
(Obj
)));
4419 return Type_Access_Level
(Etype
(Prefix
(Name
(Obj
))));
4422 -- For convenience we handle qualified expressions, even though
4423 -- they aren't technically object names.
4425 elsif Nkind
(Obj
) = N_Qualified_Expression
then
4426 return Object_Access_Level
(Expression
(Obj
));
4428 -- Otherwise return the scope level of Standard.
4429 -- (If there are cases that fall through
4430 -- to this point they will be treated as
4431 -- having global accessibility for now. ???)
4434 return Scope_Depth
(Standard_Standard
);
4436 end Object_Access_Level
;
4438 -----------------------
4439 -- Private_Component --
4440 -----------------------
4442 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
4443 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
4445 function Trace_Components
4449 -- Recursive function that does the work, and checks against circular
4450 -- definition for each subcomponent type.
4452 ----------------------
4453 -- Trace_Components --
4454 ----------------------
4456 function Trace_Components
4458 Check
: Boolean) return Entity_Id
4460 Btype
: constant Entity_Id
:= Base_Type
(T
);
4461 Component
: Entity_Id
;
4463 Candidate
: Entity_Id
:= Empty
;
4466 if Check
and then Btype
= Ancestor
then
4467 Error_Msg_N
("circular type definition", Type_Id
);
4471 if Is_Private_Type
(Btype
)
4472 and then not Is_Generic_Type
(Btype
)
4476 elsif Is_Array_Type
(Btype
) then
4477 return Trace_Components
(Component_Type
(Btype
), True);
4479 elsif Is_Record_Type
(Btype
) then
4480 Component
:= First_Entity
(Btype
);
4481 while Present
(Component
) loop
4483 -- skip anonymous types generated by constrained components.
4485 if not Is_Type
(Component
) then
4486 P
:= Trace_Components
(Etype
(Component
), True);
4489 if P
= Any_Type
then
4497 Next_Entity
(Component
);
4505 end Trace_Components
;
4507 -- Start of processing for Private_Component
4510 return Trace_Components
(Type_Id
, False);
4511 end Private_Component
;
4513 -----------------------
4514 -- Process_End_Label --
4515 -----------------------
4517 procedure Process_End_Label
4525 Label_Ref
: Boolean;
4526 -- Set True if reference to end label itself is required
4529 -- Gets set to the operator symbol or identifier that references
4530 -- the entity Ent. For the child unit case, this is the identifier
4531 -- from the designator. For other cases, this is simply Endl.
4533 procedure Generate_Parent_Ref
(N
: Node_Id
);
4534 -- N is an identifier node that appears as a parent unit reference
4535 -- in the case where Ent is a child unit. This procedure generates
4536 -- an appropriate cross-reference entry.
4538 -------------------------
4539 -- Generate_Parent_Ref --
4540 -------------------------
4542 procedure Generate_Parent_Ref
(N
: Node_Id
) is
4543 Parent_Ent
: Entity_Id
;
4546 -- Search up scope stack. The reason we do this is that normal
4547 -- visibility analysis would not work for two reasons. First in
4548 -- some subunit cases, the entry for the parent unit may not be
4549 -- visible, and in any case there can be a local entity that
4550 -- hides the scope entity.
4552 Parent_Ent
:= Current_Scope
;
4553 while Present
(Parent_Ent
) loop
4554 if Chars
(Parent_Ent
) = Chars
(N
) then
4556 -- Generate the reference. We do NOT consider this as a
4557 -- reference for unreferenced symbol purposes, but we do
4558 -- force a cross-reference even if the end line does not
4559 -- come from source (the caller already generated the
4560 -- appropriate Typ for this situation).
4563 (Parent_Ent
, N
, 'r', Set_Ref
=> False, Force
=> True);
4564 Style
.Check_Identifier
(N
, Parent_Ent
);
4568 Parent_Ent
:= Scope
(Parent_Ent
);
4571 -- Fall through means entity was not found -- that's odd, but
4572 -- the appropriate thing is simply to ignore and not generate
4573 -- any cross-reference for this entry.
4576 end Generate_Parent_Ref
;
4578 -- Start of processing for Process_End_Label
4581 -- If no node, ignore. This happens in some error situations,
4582 -- and also for some internally generated structures where no
4583 -- end label references are required in any case.
4589 -- Nothing to do if no End_Label, happens for internally generated
4590 -- constructs where we don't want an end label reference anyway.
4591 -- Also nothing to do if Endl is a string literal, which means
4592 -- there was some prior error (bad operator symbol)
4594 Endl
:= End_Label
(N
);
4596 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
4600 -- Reference node is not in extended main source unit
4602 if not In_Extended_Main_Source_Unit
(N
) then
4604 -- Generally we do not collect references except for the
4605 -- extended main source unit. The one exception is the 'e'
4606 -- entry for a package spec, where it is useful for a client
4607 -- to have the ending information to define scopes.
4615 -- For this case, we can ignore any parent references,
4616 -- but we need the package name itself for the 'e' entry.
4618 if Nkind
(Endl
) = N_Designator
then
4619 Endl
:= Identifier
(Endl
);
4623 -- Reference is in extended main source unit
4628 -- For designator, generate references for the parent entries
4630 if Nkind
(Endl
) = N_Designator
then
4632 -- Generate references for the prefix if the END line comes
4633 -- from source (otherwise we do not need these references)
4635 if Comes_From_Source
(Endl
) then
4637 while Nkind
(Nam
) = N_Selected_Component
loop
4638 Generate_Parent_Ref
(Selector_Name
(Nam
));
4639 Nam
:= Prefix
(Nam
);
4642 Generate_Parent_Ref
(Nam
);
4645 Endl
:= Identifier
(Endl
);
4649 -- If the end label is not for the given entity, then either we have
4650 -- some previous error, or this is a generic instantiation for which
4651 -- we do not need to make a cross-reference in this case anyway. In
4652 -- either case we simply ignore the call.
4654 if Chars
(Ent
) /= Chars
(Endl
) then
4658 -- If label was really there, then generate a normal reference
4659 -- and then adjust the location in the end label to point past
4660 -- the name (which should almost always be the semicolon).
4664 if Comes_From_Source
(Endl
) then
4666 -- If a label reference is required, then do the style check
4667 -- and generate an l-type cross-reference entry for the label
4670 Style
.Check_Identifier
(Endl
, Ent
);
4671 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
4674 -- Set the location to point past the label (normally this will
4675 -- mean the semicolon immediately following the label). This is
4676 -- done for the sake of the 'e' or 't' entry generated below.
4678 Get_Decoded_Name_String
(Chars
(Endl
));
4679 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
4682 -- Now generate the e/t reference
4684 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
4686 -- Restore Sloc, in case modified above, since we have an identifier
4687 -- and the normal Sloc should be left set in the tree.
4689 Set_Sloc
(Endl
, Loc
);
4690 end Process_End_Label
;
4696 -- We do the conversion to get the value of the real string by using
4697 -- the scanner, see Sinput for details on use of the internal source
4698 -- buffer for scanning internal strings.
4700 function Real_Convert
(S
: String) return Node_Id
is
4701 Save_Src
: constant Source_Buffer_Ptr
:= Source
;
4705 Source
:= Internal_Source_Ptr
;
4708 for J
in S
'Range loop
4709 Source
(Source_Ptr
(J
)) := S
(J
);
4712 Source
(S
'Length + 1) := EOF
;
4714 if Source
(Scan_Ptr
) = '-' then
4716 Scan_Ptr
:= Scan_Ptr
+ 1;
4724 Set_Realval
(Token_Node
, UR_Negate
(Realval
(Token_Node
)));
4731 ------------------------------
4732 -- Requires_Transient_Scope --
4733 ------------------------------
4735 -- A transient scope is required when variable-sized temporaries are
4736 -- allocated in the primary or secondary stack, or when finalization
4737 -- actions must be generated before the next instruction
4739 function Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean is
4740 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
4743 -- This is a private type which is not completed yet. This can only
4744 -- happen in a default expression (of a formal parameter or of a
4745 -- record component). Do not expand transient scope in this case
4750 elsif Typ
= Standard_Void_Type
then
4753 -- The back-end has trouble allocating variable-size temporaries so
4754 -- we generate them in the front-end and need a transient scope to
4755 -- reclaim them properly
4757 elsif not Size_Known_At_Compile_Time
(Typ
) then
4760 -- Unconstrained discriminated records always require a variable
4761 -- length temporary, since the length may depend on the variant.
4763 elsif Is_Record_Type
(Typ
)
4764 and then Has_Discriminants
(Typ
)
4765 and then not Is_Constrained
(Typ
)
4769 -- Functions returning tagged types may dispatch on result so their
4770 -- returned value is allocated on the secondary stack. Controlled
4771 -- type temporaries need finalization.
4773 elsif Is_Tagged_Type
(Typ
)
4774 or else Has_Controlled_Component
(Typ
)
4778 -- Unconstrained array types are returned on the secondary stack
4780 elsif Is_Array_Type
(Typ
) then
4781 return not Is_Constrained
(Typ
);
4785 end Requires_Transient_Scope
;
4787 --------------------------
4788 -- Reset_Analyzed_Flags --
4789 --------------------------
4791 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
4793 function Clear_Analyzed
4795 return Traverse_Result
;
4796 -- Function used to reset Analyzed flags in tree. Note that we do
4797 -- not reset Analyzed flags in entities, since there is no need to
4798 -- renalalyze entities, and indeed, it is wrong to do so, since it
4799 -- can result in generating auxiliary stuff more than once.
4801 function Clear_Analyzed
4803 return Traverse_Result
4806 if not Has_Extension
(N
) then
4807 Set_Analyzed
(N
, False);
4813 function Reset_Analyzed
is
4814 new Traverse_Func
(Clear_Analyzed
);
4816 Discard
: Traverse_Result
;
4818 -- Start of processing for Reset_Analyzed_Flags
4821 Discard
:= Reset_Analyzed
(N
);
4822 end Reset_Analyzed_Flags
;
4828 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
4829 K1
: constant Node_Kind
:= Nkind
(N1
);
4830 K2
: constant Node_Kind
:= Nkind
(N2
);
4833 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
4834 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
4836 return Chars
(N1
) = Chars
(N2
);
4838 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
4839 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
4841 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
4842 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
4853 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
4858 elsif not Is_Constrained
(T1
)
4859 and then not Is_Constrained
(T2
)
4860 and then Base_Type
(T1
) = Base_Type
(T2
)
4864 -- For now don't bother with case of identical constraints, to be
4865 -- fiddled with later on perhaps (this is only used for optimization
4866 -- purposes, so it is not critical to do a best possible job)
4873 ------------------------
4874 -- Scope_Is_Transient --
4875 ------------------------
4877 function Scope_Is_Transient
return Boolean is
4879 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
4880 end Scope_Is_Transient
;
4886 function Scope_Within
(Scope1
, Scope2
: Entity_Id
) return Boolean is
4891 while Scop
/= Standard_Standard
loop
4892 Scop
:= Scope
(Scop
);
4894 if Scop
= Scope2
then
4902 --------------------------
4903 -- Scope_Within_Or_Same --
4904 --------------------------
4906 function Scope_Within_Or_Same
(Scope1
, Scope2
: Entity_Id
) return Boolean is
4911 while Scop
/= Standard_Standard
loop
4912 if Scop
= Scope2
then
4915 Scop
:= Scope
(Scop
);
4920 end Scope_Within_Or_Same
;
4922 ------------------------
4923 -- Set_Current_Entity --
4924 ------------------------
4926 -- The given entity is to be set as the currently visible definition
4927 -- of its associated name (i.e. the Node_Id associated with its name).
4928 -- All we have to do is to get the name from the identifier, and
4929 -- then set the associated Node_Id to point to the given entity.
4931 procedure Set_Current_Entity
(E
: Entity_Id
) is
4933 Set_Name_Entity_Id
(Chars
(E
), E
);
4934 end Set_Current_Entity
;
4936 ---------------------------------
4937 -- Set_Entity_With_Style_Check --
4938 ---------------------------------
4940 procedure Set_Entity_With_Style_Check
(N
: Node_Id
; Val
: Entity_Id
) is
4941 Val_Actual
: Entity_Id
;
4945 Set_Entity
(N
, Val
);
4948 and then not Suppress_Style_Checks
(Val
)
4949 and then not In_Instance
4951 if Nkind
(N
) = N_Identifier
then
4954 elsif Nkind
(N
) = N_Expanded_Name
then
4955 Nod
:= Selector_Name
(N
);
4963 -- A special situation arises for derived operations, where we want
4964 -- to do the check against the parent (since the Sloc of the derived
4965 -- operation points to the derived type declaration itself).
4967 while not Comes_From_Source
(Val_Actual
)
4968 and then Nkind
(Val_Actual
) in N_Entity
4969 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
4970 or else Ekind
(Val_Actual
) = E_Function
4971 or else Ekind
(Val_Actual
) = E_Generic_Function
4972 or else Ekind
(Val_Actual
) = E_Procedure
4973 or else Ekind
(Val_Actual
) = E_Generic_Procedure
)
4974 and then Present
(Alias
(Val_Actual
))
4976 Val_Actual
:= Alias
(Val_Actual
);
4979 -- Renaming declarations for generic actuals do not come from source,
4980 -- and have a different name from that of the entity they rename, so
4981 -- there is no style check to perform here.
4983 if Chars
(Nod
) = Chars
(Val_Actual
) then
4984 Style
.Check_Identifier
(Nod
, Val_Actual
);
4989 Set_Entity
(N
, Val
);
4990 end Set_Entity_With_Style_Check
;
4992 ------------------------
4993 -- Set_Name_Entity_Id --
4994 ------------------------
4996 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
4998 Set_Name_Table_Info
(Id
, Int
(Val
));
4999 end Set_Name_Entity_Id
;
5001 ---------------------
5002 -- Set_Next_Actual --
5003 ---------------------
5005 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
5007 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
5008 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
5010 end Set_Next_Actual
;
5012 -----------------------
5013 -- Set_Public_Status --
5014 -----------------------
5016 procedure Set_Public_Status
(Id
: Entity_Id
) is
5017 S
: constant Entity_Id
:= Current_Scope
;
5020 if S
= Standard_Standard
5021 or else (Is_Public
(S
)
5022 and then (Ekind
(S
) = E_Package
5023 or else Is_Record_Type
(S
)
5024 or else Ekind
(S
) = E_Void
))
5028 -- The bounds of an entry family declaration can generate object
5029 -- declarations that are visible to the back-end, e.g. in the
5030 -- the declaration of a composite type that contains tasks.
5033 and then Is_Concurrent_Type
(S
)
5034 and then not Has_Completion
(S
)
5035 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
5039 end Set_Public_Status
;
5041 ----------------------------
5042 -- Set_Scope_Is_Transient --
5043 ----------------------------
5045 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
5047 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
5048 end Set_Scope_Is_Transient
;
5054 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
5056 -- We copy Esize, but not RM_Size, since in general RM_Size is
5057 -- subtype specific and does not get inherited by all subtypes.
5059 Set_Esize
(T1
, Esize
(T2
));
5060 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
5062 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
5064 Is_Discrete_Or_Fixed_Point_Type
(T2
)
5066 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
5069 Set_Alignment
(T1
, Alignment
(T2
));
5072 --------------------
5073 -- Static_Integer --
5074 --------------------
5076 function Static_Integer
(N
: Node_Id
) return Uint
is
5078 Analyze_And_Resolve
(N
, Any_Integer
);
5081 or else Error_Posted
(N
)
5082 or else Etype
(N
) = Any_Type
5087 if Is_Static_Expression
(N
) then
5088 if not Raises_Constraint_Error
(N
) then
5089 return Expr_Value
(N
);
5094 elsif Etype
(N
) = Any_Type
then
5098 Error_Msg_N
("static integer expression required here", N
);
5103 --------------------------
5104 -- Statically_Different --
5105 --------------------------
5107 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
5108 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
5109 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
5112 return Is_Entity_Name
(R1
)
5113 and then Is_Entity_Name
(R2
)
5114 and then Entity
(R1
) /= Entity
(R2
)
5115 and then not Is_Formal
(Entity
(R1
))
5116 and then not Is_Formal
(Entity
(R2
));
5117 end Statically_Different
;
5119 -----------------------------
5120 -- Subprogram_Access_Level --
5121 -----------------------------
5123 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
5125 if Present
(Alias
(Subp
)) then
5126 return Subprogram_Access_Level
(Alias
(Subp
));
5128 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
5130 end Subprogram_Access_Level
;
5136 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
5138 if Debug_Flag_W
then
5139 for J
in 0 .. Scope_Stack
.Last
loop
5144 Write_Name
(Chars
(E
));
5145 Write_Str
(" line ");
5146 Write_Int
(Int
(Get_Logical_Line_Number
(Sloc
(N
))));
5151 -----------------------
5152 -- Transfer_Entities --
5153 -----------------------
5155 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
5156 Ent
: Entity_Id
:= First_Entity
(From
);
5163 if (Last_Entity
(To
)) = Empty
then
5164 Set_First_Entity
(To
, Ent
);
5166 Set_Next_Entity
(Last_Entity
(To
), Ent
);
5169 Set_Last_Entity
(To
, Last_Entity
(From
));
5171 while Present
(Ent
) loop
5172 Set_Scope
(Ent
, To
);
5174 if not Is_Public
(Ent
) then
5175 Set_Public_Status
(Ent
);
5178 and then Ekind
(Ent
) = E_Record_Subtype
5181 -- The components of the propagated Itype must be public
5188 Comp
:= First_Entity
(Ent
);
5190 while Present
(Comp
) loop
5191 Set_Is_Public
(Comp
);
5201 Set_First_Entity
(From
, Empty
);
5202 Set_Last_Entity
(From
, Empty
);
5203 end Transfer_Entities
;
5205 -----------------------
5206 -- Type_Access_Level --
5207 -----------------------
5209 function Type_Access_Level
(Typ
: Entity_Id
) return Uint
is
5210 Btyp
: Entity_Id
:= Base_Type
(Typ
);
5213 -- If the type is an anonymous access type we treat it as being
5214 -- declared at the library level to ensure that names such as
5215 -- X.all'access don't fail static accessibility checks.
5217 if Ekind
(Btyp
) in Access_Kind
then
5218 if Ekind
(Btyp
) = E_Anonymous_Access_Type
then
5219 return Scope_Depth
(Standard_Standard
);
5222 Btyp
:= Root_Type
(Btyp
);
5225 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
5226 end Type_Access_Level
;
5228 --------------------------
5229 -- Unit_Declaration_Node --
5230 --------------------------
5232 function Unit_Declaration_Node
(Unit_Id
: Entity_Id
) return Node_Id
is
5233 N
: Node_Id
:= Parent
(Unit_Id
);
5236 -- Predefined operators do not have a full function declaration.
5238 if Ekind
(Unit_Id
) = E_Operator
then
5242 while Nkind
(N
) /= N_Abstract_Subprogram_Declaration
5243 and then Nkind
(N
) /= N_Formal_Package_Declaration
5244 and then Nkind
(N
) /= N_Formal_Subprogram_Declaration
5245 and then Nkind
(N
) /= N_Function_Instantiation
5246 and then Nkind
(N
) /= N_Generic_Package_Declaration
5247 and then Nkind
(N
) /= N_Generic_Subprogram_Declaration
5248 and then Nkind
(N
) /= N_Package_Declaration
5249 and then Nkind
(N
) /= N_Package_Body
5250 and then Nkind
(N
) /= N_Package_Instantiation
5251 and then Nkind
(N
) /= N_Package_Renaming_Declaration
5252 and then Nkind
(N
) /= N_Procedure_Instantiation
5253 and then Nkind
(N
) /= N_Subprogram_Declaration
5254 and then Nkind
(N
) /= N_Subprogram_Body
5255 and then Nkind
(N
) /= N_Subprogram_Body_Stub
5256 and then Nkind
(N
) /= N_Subprogram_Renaming_Declaration
5257 and then Nkind
(N
) /= N_Task_Body
5258 and then Nkind
(N
) /= N_Task_Type_Declaration
5259 and then Nkind
(N
) not in N_Generic_Renaming_Declaration
5262 pragma Assert
(Present
(N
));
5266 end Unit_Declaration_Node
;
5268 ----------------------
5269 -- Within_Init_Proc --
5270 ----------------------
5272 function Within_Init_Proc
return Boolean is
5277 while not Is_Overloadable
(S
) loop
5278 if S
= Standard_Standard
then
5285 return Chars
(S
) = Name_uInit_Proc
;
5286 end Within_Init_Proc
;
5292 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
5293 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
5294 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
5296 function Has_One_Matching_Field
return Boolean;
5297 -- Determines whether Expec_Type is a record type with a single
5298 -- component or discriminant whose type matches the found type or
5299 -- is a one dimensional array whose component type matches the
5302 function Has_One_Matching_Field
return Boolean is
5306 if Is_Array_Type
(Expec_Type
)
5307 and then Number_Dimensions
(Expec_Type
) = 1
5309 Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
5313 elsif not Is_Record_Type
(Expec_Type
) then
5317 E
:= First_Entity
(Expec_Type
);
5323 elsif (Ekind
(E
) /= E_Discriminant
5324 and then Ekind
(E
) /= E_Component
)
5325 or else (Chars
(E
) = Name_uTag
5326 or else Chars
(E
) = Name_uParent
)
5335 if not Covers
(Etype
(E
), Found_Type
) then
5338 elsif Present
(Next_Entity
(E
)) then
5345 end Has_One_Matching_Field
;
5347 -- Start of processing for Wrong_Type
5350 -- Don't output message if either type is Any_Type, or if a message
5351 -- has already been posted for this node. We need to do the latter
5352 -- check explicitly (it is ordinarily done in Errout), because we
5353 -- are using ! to force the output of the error messages.
5355 if Expec_Type
= Any_Type
5356 or else Found_Type
= Any_Type
5357 or else Error_Posted
(Expr
)
5361 -- In an instance, there is an ongoing problem with completion of
5362 -- type derived from private types. Their structure is what Gigi
5363 -- expects, but the Etype is the parent type rather than the
5364 -- derived private type itself. Do not flag error in this case. The
5365 -- private completion is an entity without a parent, like an Itype.
5366 -- Similarly, full and partial views may be incorrect in the instance.
5367 -- There is no simple way to insure that it is consistent ???
5369 elsif In_Instance
then
5371 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
5372 and then No
(Parent
(Expected_Type
))
5378 -- An interesting special check. If the expression is parenthesized
5379 -- and its type corresponds to the type of the sole component of the
5380 -- expected record type, or to the component type of the expected one
5381 -- dimensional array type, then assume we have a bad aggregate attempt.
5383 if Nkind
(Expr
) in N_Subexpr
5384 and then Paren_Count
(Expr
) /= 0
5385 and then Has_One_Matching_Field
5387 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
5389 -- Another special check, if we are looking for a pool-specific access
5390 -- type and we found an E_Access_Attribute_Type, then we have the case
5391 -- of an Access attribute being used in a context which needs a pool-
5392 -- specific type, which is never allowed. The one extra check we make
5393 -- is that the expected designated type covers the Found_Type.
5395 elsif Is_Access_Type
(Expec_Type
)
5396 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
5397 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
5398 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
5400 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
5402 Error_Msg_N
("result must be general access type!", Expr
);
5403 Error_Msg_NE
("add ALL to }!", Expr
, Expec_Type
);
5405 -- If the expected type is an anonymous access type, as for access
5406 -- parameters and discriminants, the error is on the designated types.
5408 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
5409 if Comes_From_Source
(Expec_Type
) then
5410 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
5413 ("expected an access type with designated}",
5414 Expr
, Designated_Type
(Expec_Type
));
5417 if Is_Access_Type
(Found_Type
)
5418 and then not Comes_From_Source
(Found_Type
)
5421 ("found an access type with designated}!",
5422 Expr
, Designated_Type
(Found_Type
));
5424 if From_With_Type
(Found_Type
) then
5425 Error_Msg_NE
("found incomplete}!", Expr
, Found_Type
);
5427 ("\possibly missing with_clause on&", Expr
,
5428 Scope
(Found_Type
));
5430 Error_Msg_NE
("found}!", Expr
, Found_Type
);
5434 -- Normal case of one type found, some other type expected
5437 -- If the names of the two types are the same, see if some
5438 -- number of levels of qualification will help. Don't try
5439 -- more than three levels, and if we get to standard, it's
5440 -- no use (and probably represents an error in the compiler)
5441 -- Also do not bother with internal scope names.
5444 Expec_Scope
: Entity_Id
;
5445 Found_Scope
: Entity_Id
;
5448 Expec_Scope
:= Expec_Type
;
5449 Found_Scope
:= Found_Type
;
5451 for Levels
in Int
range 0 .. 3 loop
5452 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
5453 Error_Msg_Qual_Level
:= Levels
;
5457 Expec_Scope
:= Scope
(Expec_Scope
);
5458 Found_Scope
:= Scope
(Found_Scope
);
5460 exit when Expec_Scope
= Standard_Standard
5462 Found_Scope
= Standard_Standard
5464 not Comes_From_Source
(Expec_Scope
)
5466 not Comes_From_Source
(Found_Scope
);
5470 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
5472 if Is_Entity_Name
(Expr
)
5473 and then Is_Package
(Entity
(Expr
))
5475 Error_Msg_N
("found package name!", Expr
);
5477 elsif Is_Entity_Name
(Expr
)
5479 (Ekind
(Entity
(Expr
)) = E_Procedure
5481 Ekind
(Entity
(Expr
)) = E_Generic_Procedure
)
5483 Error_Msg_N
("found procedure name instead of function!", Expr
);
5485 -- catch common error: a prefix or infix operator which is not
5486 -- directly visible because the type isn't.
5488 elsif Nkind
(Expr
) in N_Op
5489 and then Is_Overloaded
(Expr
)
5490 and then not Is_Immediately_Visible
(Expec_Type
)
5491 and then not Is_Potentially_Use_Visible
(Expec_Type
)
5492 and then not In_Use
(Expec_Type
)
5493 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
5496 "operator of the type is not directly visible!", Expr
);
5499 Error_Msg_NE
("found}!", Expr
, Found_Type
);
5502 Error_Msg_Qual_Level
:= 0;