1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Casing
; use Casing
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Errout
; use Errout
;
31 with Elists
; use Elists
;
32 with Exp_Ch11
; use Exp_Ch11
;
33 with Exp_Disp
; use Exp_Disp
;
34 with Exp_Tss
; use Exp_Tss
;
35 with Exp_Util
; use Exp_Util
;
36 with Fname
; use Fname
;
37 with Freeze
; use Freeze
;
39 with Lib
.Xref
; use Lib
.Xref
;
40 with Nlists
; use Nlists
;
41 with Output
; use Output
;
43 with Rtsfind
; use Rtsfind
;
44 with Scans
; use Scans
;
47 with Sem_Aux
; use Sem_Aux
;
48 with Sem_Attr
; use Sem_Attr
;
49 with Sem_Ch8
; use Sem_Ch8
;
50 with Sem_Disp
; use Sem_Disp
;
51 with Sem_Eval
; use Sem_Eval
;
52 with Sem_Res
; use Sem_Res
;
53 with Sem_Type
; use Sem_Type
;
54 with Sinfo
; use Sinfo
;
55 with Sinput
; use Sinput
;
56 with Stand
; use Stand
;
58 with Stringt
; use Stringt
;
60 with Targparm
; use Targparm
;
61 with Tbuild
; use Tbuild
;
62 with Ttypes
; use Ttypes
;
63 with Uname
; use Uname
;
65 with GNAT
.HTable
; use GNAT
.HTable
;
67 package body Sem_Util
is
69 ----------------------------------------
70 -- Global_Variables for New_Copy_Tree --
71 ----------------------------------------
73 -- These global variables are used by New_Copy_Tree. See description
74 -- of the body of this subprogram for details. Global variables can be
75 -- safely used by New_Copy_Tree, since there is no case of a recursive
76 -- call from the processing inside New_Copy_Tree.
78 NCT_Hash_Threshhold
: constant := 20;
79 -- If there are more than this number of pairs of entries in the
80 -- map, then Hash_Tables_Used will be set, and the hash tables will
81 -- be initialized and used for the searches.
83 NCT_Hash_Tables_Used
: Boolean := False;
84 -- Set to True if hash tables are in use
86 NCT_Table_Entries
: Nat
;
87 -- Count entries in table to see if threshhold is reached
89 NCT_Hash_Table_Setup
: Boolean := False;
90 -- Set to True if hash table contains data. We set this True if we
91 -- setup the hash table with data, and leave it set permanently
92 -- from then on, this is a signal that second and subsequent users
93 -- of the hash table must clear the old entries before reuse.
95 subtype NCT_Header_Num
is Int
range 0 .. 511;
96 -- Defines range of headers in hash tables (512 headers)
98 ----------------------------------
99 -- Order Dependence (AI05-0144) --
100 ----------------------------------
102 -- Each actual in a call is entered into the table below. A flag indicates
103 -- whether the corresponding formal is OUT or IN OUT. Each top-level call
104 -- (procedure call, condition, assignment) examines all the actuals for a
105 -- possible order dependence. The table is reset after each such check.
107 type Actual_Name
is record
109 Is_Writable
: Boolean;
110 -- Comments needed???
114 package Actuals_In_Call
is new Table
.Table
(
115 Table_Component_Type
=> Actual_Name
,
116 Table_Index_Type
=> Int
,
117 Table_Low_Bound
=> 0,
119 Table_Increment
=> 100,
120 Table_Name
=> "Actuals");
122 -----------------------
123 -- Local Subprograms --
124 -----------------------
126 function Build_Component_Subtype
129 T
: Entity_Id
) return Node_Id
;
130 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
131 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
132 -- Loc is the source location, T is the original subtype.
134 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean;
135 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
136 -- with discriminants whose default values are static, examine only the
137 -- components in the selected variant to determine whether all of them
140 function Has_Null_Extension
(T
: Entity_Id
) return Boolean;
141 -- T is a derived tagged type. Check whether the type extension is null.
142 -- If the parent type is fully initialized, T can be treated as such.
144 ------------------------------
145 -- Abstract_Interface_List --
146 ------------------------------
148 function Abstract_Interface_List
(Typ
: Entity_Id
) return List_Id
is
152 if Is_Concurrent_Type
(Typ
) then
154 -- If we are dealing with a synchronized subtype, go to the base
155 -- type, whose declaration has the interface list.
157 -- Shouldn't this be Declaration_Node???
159 Nod
:= Parent
(Base_Type
(Typ
));
161 if Nkind
(Nod
) = N_Full_Type_Declaration
then
165 elsif Ekind
(Typ
) = E_Record_Type_With_Private
then
166 if Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
then
167 Nod
:= Type_Definition
(Parent
(Typ
));
169 elsif Nkind
(Parent
(Typ
)) = N_Private_Type_Declaration
then
170 if Present
(Full_View
(Typ
)) then
171 Nod
:= Type_Definition
(Parent
(Full_View
(Typ
)));
173 -- If the full-view is not available we cannot do anything else
174 -- here (the source has errors).
180 -- Support for generic formals with interfaces is still missing ???
182 elsif Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
187 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
);
191 elsif Ekind
(Typ
) = E_Record_Subtype
then
192 Nod
:= Type_Definition
(Parent
(Etype
(Typ
)));
194 elsif Ekind
(Typ
) = E_Record_Subtype_With_Private
then
196 -- Recurse, because parent may still be a private extension. Also
197 -- note that the full view of the subtype or the full view of its
198 -- base type may (both) be unavailable.
200 return Abstract_Interface_List
(Etype
(Typ
));
202 else pragma Assert
((Ekind
(Typ
)) = E_Record_Type
);
203 if Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
204 Nod
:= Formal_Type_Definition
(Parent
(Typ
));
206 Nod
:= Type_Definition
(Parent
(Typ
));
210 return Interface_List
(Nod
);
211 end Abstract_Interface_List
;
213 --------------------------------
214 -- Add_Access_Type_To_Process --
215 --------------------------------
217 procedure Add_Access_Type_To_Process
(E
: Entity_Id
; A
: Entity_Id
) is
221 Ensure_Freeze_Node
(E
);
222 L
:= Access_Types_To_Process
(Freeze_Node
(E
));
226 Set_Access_Types_To_Process
(Freeze_Node
(E
), L
);
230 end Add_Access_Type_To_Process
;
232 ----------------------------
233 -- Add_Global_Declaration --
234 ----------------------------
236 procedure Add_Global_Declaration
(N
: Node_Id
) is
237 Aux_Node
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Current_Sem_Unit
));
240 if No
(Declarations
(Aux_Node
)) then
241 Set_Declarations
(Aux_Node
, New_List
);
244 Append_To
(Declarations
(Aux_Node
), N
);
246 end Add_Global_Declaration
;
248 -----------------------
249 -- Alignment_In_Bits --
250 -----------------------
252 function Alignment_In_Bits
(E
: Entity_Id
) return Uint
is
254 return Alignment
(E
) * System_Storage_Unit
;
255 end Alignment_In_Bits
;
257 -----------------------------------------
258 -- Apply_Compile_Time_Constraint_Error --
259 -----------------------------------------
261 procedure Apply_Compile_Time_Constraint_Error
264 Reason
: RT_Exception_Code
;
265 Ent
: Entity_Id
:= Empty
;
266 Typ
: Entity_Id
:= Empty
;
267 Loc
: Source_Ptr
:= No_Location
;
268 Rep
: Boolean := True;
269 Warn
: Boolean := False)
271 Stat
: constant Boolean := Is_Static_Expression
(N
);
272 R_Stat
: constant Node_Id
:=
273 Make_Raise_Constraint_Error
(Sloc
(N
), Reason
=> Reason
);
284 (Compile_Time_Constraint_Error
(N
, Msg
, Ent
, Loc
, Warn
=> Warn
));
290 -- Now we replace the node by an N_Raise_Constraint_Error node
291 -- This does not need reanalyzing, so set it as analyzed now.
294 Set_Analyzed
(N
, True);
297 Set_Raises_Constraint_Error
(N
);
299 -- Now deal with possible local raise handling
301 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
303 -- If the original expression was marked as static, the result is
304 -- still marked as static, but the Raises_Constraint_Error flag is
305 -- always set so that further static evaluation is not attempted.
308 Set_Is_Static_Expression
(N
);
310 end Apply_Compile_Time_Constraint_Error
;
312 --------------------------
313 -- Build_Actual_Subtype --
314 --------------------------
316 function Build_Actual_Subtype
318 N
: Node_Or_Entity_Id
) return Node_Id
321 -- Normally Sloc (N), but may point to corresponding body in some cases
323 Constraints
: List_Id
;
329 Disc_Type
: Entity_Id
;
335 if Nkind
(N
) = N_Defining_Identifier
then
336 Obj
:= New_Reference_To
(N
, Loc
);
338 -- If this is a formal parameter of a subprogram declaration, and
339 -- we are compiling the body, we want the declaration for the
340 -- actual subtype to carry the source position of the body, to
341 -- prevent anomalies in gdb when stepping through the code.
343 if Is_Formal
(N
) then
345 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(N
));
347 if Nkind
(Decl
) = N_Subprogram_Declaration
348 and then Present
(Corresponding_Body
(Decl
))
350 Loc
:= Sloc
(Corresponding_Body
(Decl
));
359 if Is_Array_Type
(T
) then
360 Constraints
:= New_List
;
361 for J
in 1 .. Number_Dimensions
(T
) loop
363 -- Build an array subtype declaration with the nominal subtype and
364 -- the bounds of the actual. Add the declaration in front of the
365 -- local declarations for the subprogram, for analysis before any
366 -- reference to the formal in the body.
369 Make_Attribute_Reference
(Loc
,
371 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
372 Attribute_Name
=> Name_First
,
373 Expressions
=> New_List
(
374 Make_Integer_Literal
(Loc
, J
)));
377 Make_Attribute_Reference
(Loc
,
379 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
380 Attribute_Name
=> Name_Last
,
381 Expressions
=> New_List
(
382 Make_Integer_Literal
(Loc
, J
)));
384 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
387 -- If the type has unknown discriminants there is no constrained
388 -- subtype to build. This is never called for a formal or for a
389 -- lhs, so returning the type is ok ???
391 elsif Has_Unknown_Discriminants
(T
) then
395 Constraints
:= New_List
;
397 -- Type T is a generic derived type, inherit the discriminants from
400 if Is_Private_Type
(T
)
401 and then No
(Full_View
(T
))
403 -- T was flagged as an error if it was declared as a formal
404 -- derived type with known discriminants. In this case there
405 -- is no need to look at the parent type since T already carries
406 -- its own discriminants.
408 and then not Error_Posted
(T
)
410 Disc_Type
:= Etype
(Base_Type
(T
));
415 Discr
:= First_Discriminant
(Disc_Type
);
416 while Present
(Discr
) loop
417 Append_To
(Constraints
,
418 Make_Selected_Component
(Loc
,
420 Duplicate_Subexpr_No_Checks
(Obj
),
421 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)));
422 Next_Discriminant
(Discr
);
426 Subt
:= Make_Temporary
(Loc
, 'S', Related_Node
=> N
);
427 Set_Is_Internal
(Subt
);
430 Make_Subtype_Declaration
(Loc
,
431 Defining_Identifier
=> Subt
,
432 Subtype_Indication
=>
433 Make_Subtype_Indication
(Loc
,
434 Subtype_Mark
=> New_Reference_To
(T
, Loc
),
436 Make_Index_Or_Discriminant_Constraint
(Loc
,
437 Constraints
=> Constraints
)));
439 Mark_Rewrite_Insertion
(Decl
);
441 end Build_Actual_Subtype
;
443 ---------------------------------------
444 -- Build_Actual_Subtype_Of_Component --
445 ---------------------------------------
447 function Build_Actual_Subtype_Of_Component
449 N
: Node_Id
) return Node_Id
451 Loc
: constant Source_Ptr
:= Sloc
(N
);
452 P
: constant Node_Id
:= Prefix
(N
);
455 Indx_Type
: Entity_Id
;
457 Deaccessed_T
: Entity_Id
;
458 -- This is either a copy of T, or if T is an access type, then it is
459 -- the directly designated type of this access type.
461 function Build_Actual_Array_Constraint
return List_Id
;
462 -- If one or more of the bounds of the component depends on
463 -- discriminants, build actual constraint using the discriminants
466 function Build_Actual_Record_Constraint
return List_Id
;
467 -- Similar to previous one, for discriminated components constrained
468 -- by the discriminant of the enclosing object.
470 -----------------------------------
471 -- Build_Actual_Array_Constraint --
472 -----------------------------------
474 function Build_Actual_Array_Constraint
return List_Id
is
475 Constraints
: constant List_Id
:= New_List
;
483 Indx
:= First_Index
(Deaccessed_T
);
484 while Present
(Indx
) loop
485 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
486 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
488 if Denotes_Discriminant
(Old_Lo
) then
490 Make_Selected_Component
(Loc
,
491 Prefix
=> New_Copy_Tree
(P
),
492 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Lo
), Loc
));
495 Lo
:= New_Copy_Tree
(Old_Lo
);
497 -- The new bound will be reanalyzed in the enclosing
498 -- declaration. For literal bounds that come from a type
499 -- declaration, the type of the context must be imposed, so
500 -- insure that analysis will take place. For non-universal
501 -- types this is not strictly necessary.
503 Set_Analyzed
(Lo
, False);
506 if Denotes_Discriminant
(Old_Hi
) then
508 Make_Selected_Component
(Loc
,
509 Prefix
=> New_Copy_Tree
(P
),
510 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Hi
), Loc
));
513 Hi
:= New_Copy_Tree
(Old_Hi
);
514 Set_Analyzed
(Hi
, False);
517 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
522 end Build_Actual_Array_Constraint
;
524 ------------------------------------
525 -- Build_Actual_Record_Constraint --
526 ------------------------------------
528 function Build_Actual_Record_Constraint
return List_Id
is
529 Constraints
: constant List_Id
:= New_List
;
534 D
:= First_Elmt
(Discriminant_Constraint
(Deaccessed_T
));
535 while Present
(D
) loop
536 if Denotes_Discriminant
(Node
(D
)) then
537 D_Val
:= Make_Selected_Component
(Loc
,
538 Prefix
=> New_Copy_Tree
(P
),
539 Selector_Name
=> New_Occurrence_Of
(Entity
(Node
(D
)), Loc
));
542 D_Val
:= New_Copy_Tree
(Node
(D
));
545 Append
(D_Val
, Constraints
);
550 end Build_Actual_Record_Constraint
;
552 -- Start of processing for Build_Actual_Subtype_Of_Component
555 -- Why the test for Spec_Expression mode here???
557 if In_Spec_Expression
then
560 -- More comments for the rest of this body would be good ???
562 elsif Nkind
(N
) = N_Explicit_Dereference
then
563 if Is_Composite_Type
(T
)
564 and then not Is_Constrained
(T
)
565 and then not (Is_Class_Wide_Type
(T
)
566 and then Is_Constrained
(Root_Type
(T
)))
567 and then not Has_Unknown_Discriminants
(T
)
569 -- If the type of the dereference is already constrained, it is an
572 if Is_Array_Type
(Etype
(N
))
573 and then Is_Constrained
(Etype
(N
))
577 Remove_Side_Effects
(P
);
578 return Build_Actual_Subtype
(T
, N
);
585 if Ekind
(T
) = E_Access_Subtype
then
586 Deaccessed_T
:= Designated_Type
(T
);
591 if Ekind
(Deaccessed_T
) = E_Array_Subtype
then
592 Id
:= First_Index
(Deaccessed_T
);
593 while Present
(Id
) loop
594 Indx_Type
:= Underlying_Type
(Etype
(Id
));
596 if Denotes_Discriminant
(Type_Low_Bound
(Indx_Type
))
598 Denotes_Discriminant
(Type_High_Bound
(Indx_Type
))
600 Remove_Side_Effects
(P
);
602 Build_Component_Subtype
603 (Build_Actual_Array_Constraint
, Loc
, Base_Type
(T
));
609 elsif Is_Composite_Type
(Deaccessed_T
)
610 and then Has_Discriminants
(Deaccessed_T
)
611 and then not Has_Unknown_Discriminants
(Deaccessed_T
)
613 D
:= First_Elmt
(Discriminant_Constraint
(Deaccessed_T
));
614 while Present
(D
) loop
615 if Denotes_Discriminant
(Node
(D
)) then
616 Remove_Side_Effects
(P
);
618 Build_Component_Subtype
(
619 Build_Actual_Record_Constraint
, Loc
, Base_Type
(T
));
626 -- If none of the above, the actual and nominal subtypes are the same
629 end Build_Actual_Subtype_Of_Component
;
631 -----------------------------
632 -- Build_Component_Subtype --
633 -----------------------------
635 function Build_Component_Subtype
638 T
: Entity_Id
) return Node_Id
644 -- Unchecked_Union components do not require component subtypes
646 if Is_Unchecked_Union
(T
) then
650 Subt
:= Make_Temporary
(Loc
, 'S');
651 Set_Is_Internal
(Subt
);
654 Make_Subtype_Declaration
(Loc
,
655 Defining_Identifier
=> Subt
,
656 Subtype_Indication
=>
657 Make_Subtype_Indication
(Loc
,
658 Subtype_Mark
=> New_Reference_To
(Base_Type
(T
), Loc
),
660 Make_Index_Or_Discriminant_Constraint
(Loc
,
663 Mark_Rewrite_Insertion
(Decl
);
665 end Build_Component_Subtype
;
667 ---------------------------
668 -- Build_Default_Subtype --
669 ---------------------------
671 function Build_Default_Subtype
673 N
: Node_Id
) return Entity_Id
675 Loc
: constant Source_Ptr
:= Sloc
(N
);
679 if not Has_Discriminants
(T
) or else Is_Constrained
(T
) then
683 Disc
:= First_Discriminant
(T
);
685 if No
(Discriminant_Default_Value
(Disc
)) then
690 Act
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
691 Constraints
: constant List_Id
:= New_List
;
695 while Present
(Disc
) loop
696 Append_To
(Constraints
,
697 New_Copy_Tree
(Discriminant_Default_Value
(Disc
)));
698 Next_Discriminant
(Disc
);
702 Make_Subtype_Declaration
(Loc
,
703 Defining_Identifier
=> Act
,
704 Subtype_Indication
=>
705 Make_Subtype_Indication
(Loc
,
706 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
708 Make_Index_Or_Discriminant_Constraint
(Loc
,
709 Constraints
=> Constraints
)));
711 Insert_Action
(N
, Decl
);
715 end Build_Default_Subtype
;
717 --------------------------------------------
718 -- Build_Discriminal_Subtype_Of_Component --
719 --------------------------------------------
721 function Build_Discriminal_Subtype_Of_Component
722 (T
: Entity_Id
) return Node_Id
724 Loc
: constant Source_Ptr
:= Sloc
(T
);
728 function Build_Discriminal_Array_Constraint
return List_Id
;
729 -- If one or more of the bounds of the component depends on
730 -- discriminants, build actual constraint using the discriminants
733 function Build_Discriminal_Record_Constraint
return List_Id
;
734 -- Similar to previous one, for discriminated components constrained
735 -- by the discriminant of the enclosing object.
737 ----------------------------------------
738 -- Build_Discriminal_Array_Constraint --
739 ----------------------------------------
741 function Build_Discriminal_Array_Constraint
return List_Id
is
742 Constraints
: constant List_Id
:= New_List
;
750 Indx
:= First_Index
(T
);
751 while Present
(Indx
) loop
752 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
753 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
755 if Denotes_Discriminant
(Old_Lo
) then
756 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
759 Lo
:= New_Copy_Tree
(Old_Lo
);
762 if Denotes_Discriminant
(Old_Hi
) then
763 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
766 Hi
:= New_Copy_Tree
(Old_Hi
);
769 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
774 end Build_Discriminal_Array_Constraint
;
776 -----------------------------------------
777 -- Build_Discriminal_Record_Constraint --
778 -----------------------------------------
780 function Build_Discriminal_Record_Constraint
return List_Id
is
781 Constraints
: constant List_Id
:= New_List
;
786 D
:= First_Elmt
(Discriminant_Constraint
(T
));
787 while Present
(D
) loop
788 if Denotes_Discriminant
(Node
(D
)) then
790 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
793 D_Val
:= New_Copy_Tree
(Node
(D
));
796 Append
(D_Val
, Constraints
);
801 end Build_Discriminal_Record_Constraint
;
803 -- Start of processing for Build_Discriminal_Subtype_Of_Component
806 if Ekind
(T
) = E_Array_Subtype
then
807 Id
:= First_Index
(T
);
808 while Present
(Id
) loop
809 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
))) or else
810 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
812 return Build_Component_Subtype
813 (Build_Discriminal_Array_Constraint
, Loc
, T
);
819 elsif Ekind
(T
) = E_Record_Subtype
820 and then Has_Discriminants
(T
)
821 and then not Has_Unknown_Discriminants
(T
)
823 D
:= First_Elmt
(Discriminant_Constraint
(T
));
824 while Present
(D
) loop
825 if Denotes_Discriminant
(Node
(D
)) then
826 return Build_Component_Subtype
827 (Build_Discriminal_Record_Constraint
, Loc
, T
);
834 -- If none of the above, the actual and nominal subtypes are the same
837 end Build_Discriminal_Subtype_Of_Component
;
839 ------------------------------
840 -- Build_Elaboration_Entity --
841 ------------------------------
843 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
844 Loc
: constant Source_Ptr
:= Sloc
(N
);
846 Elab_Ent
: Entity_Id
;
848 procedure Set_Package_Name
(Ent
: Entity_Id
);
849 -- Given an entity, sets the fully qualified name of the entity in
850 -- Name_Buffer, with components separated by double underscores. This
851 -- is a recursive routine that climbs the scope chain to Standard.
853 ----------------------
854 -- Set_Package_Name --
855 ----------------------
857 procedure Set_Package_Name
(Ent
: Entity_Id
) is
859 if Scope
(Ent
) /= Standard_Standard
then
860 Set_Package_Name
(Scope
(Ent
));
863 Nam
: constant String := Get_Name_String
(Chars
(Ent
));
865 Name_Buffer
(Name_Len
+ 1) := '_';
866 Name_Buffer
(Name_Len
+ 2) := '_';
867 Name_Buffer
(Name_Len
+ 3 .. Name_Len
+ Nam
'Length + 2) := Nam
;
868 Name_Len
:= Name_Len
+ Nam
'Length + 2;
872 Get_Name_String
(Chars
(Ent
));
874 end Set_Package_Name
;
876 -- Start of processing for Build_Elaboration_Entity
879 -- Ignore if already constructed
881 if Present
(Elaboration_Entity
(Spec_Id
)) then
885 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
886 -- name with dots replaced by double underscore. We have to manually
887 -- construct this name, since it will be elaborated in the outer scope,
888 -- and thus will not have the unit name automatically prepended.
890 Set_Package_Name
(Spec_Id
);
894 Name_Buffer
(Name_Len
+ 1) := '_';
895 Name_Buffer
(Name_Len
+ 2) := 'E';
896 Name_Len
:= Name_Len
+ 2;
898 -- Create elaboration flag
901 Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
902 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
905 Make_Object_Declaration
(Loc
,
906 Defining_Identifier
=> Elab_Ent
,
908 New_Occurrence_Of
(Standard_Boolean
, Loc
),
910 New_Occurrence_Of
(Standard_False
, Loc
));
912 Push_Scope
(Standard_Standard
);
913 Add_Global_Declaration
(Decl
);
916 -- Reset True_Constant indication, since we will indeed assign a value
917 -- to the variable in the binder main. We also kill the Current_Value
918 -- and Last_Assignment fields for the same reason.
920 Set_Is_True_Constant
(Elab_Ent
, False);
921 Set_Current_Value
(Elab_Ent
, Empty
);
922 Set_Last_Assignment
(Elab_Ent
, Empty
);
924 -- We do not want any further qualification of the name (if we did
925 -- not do this, we would pick up the name of the generic package
926 -- in the case of a library level generic instantiation).
928 Set_Has_Qualified_Name
(Elab_Ent
);
929 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
930 end Build_Elaboration_Entity
;
932 -----------------------------------
933 -- Cannot_Raise_Constraint_Error --
934 -----------------------------------
936 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
938 if Compile_Time_Known_Value
(Expr
) then
941 elsif Do_Range_Check
(Expr
) then
944 elsif Raises_Constraint_Error
(Expr
) then
952 when N_Expanded_Name
=>
955 when N_Selected_Component
=>
956 return not Do_Discriminant_Check
(Expr
);
958 when N_Attribute_Reference
=>
959 if Do_Overflow_Check
(Expr
) then
962 elsif No
(Expressions
(Expr
)) then
970 N
:= First
(Expressions
(Expr
));
971 while Present
(N
) loop
972 if Cannot_Raise_Constraint_Error
(N
) then
983 when N_Type_Conversion
=>
984 if Do_Overflow_Check
(Expr
)
985 or else Do_Length_Check
(Expr
)
986 or else Do_Tag_Check
(Expr
)
991 Cannot_Raise_Constraint_Error
(Expression
(Expr
));
994 when N_Unchecked_Type_Conversion
=>
995 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
998 if Do_Overflow_Check
(Expr
) then
1002 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
1009 if Do_Division_Check
(Expr
)
1010 or else Do_Overflow_Check
(Expr
)
1015 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
1017 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
1036 N_Op_Shift_Right_Arithmetic |
1040 if Do_Overflow_Check
(Expr
) then
1044 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
1046 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
1053 end Cannot_Raise_Constraint_Error
;
1055 -----------------------------------------
1056 -- Check_Dynamically_Tagged_Expression --
1057 -----------------------------------------
1059 procedure Check_Dynamically_Tagged_Expression
1062 Related_Nod
: Node_Id
)
1065 pragma Assert
(Is_Tagged_Type
(Typ
));
1067 -- In order to avoid spurious errors when analyzing the expanded code,
1068 -- this check is done only for nodes that come from source and for
1069 -- actuals of generic instantiations.
1071 if (Comes_From_Source
(Related_Nod
)
1072 or else In_Generic_Actual
(Expr
))
1073 and then (Is_Class_Wide_Type
(Etype
(Expr
))
1074 or else Is_Dynamically_Tagged
(Expr
))
1075 and then Is_Tagged_Type
(Typ
)
1076 and then not Is_Class_Wide_Type
(Typ
)
1078 Error_Msg_N
("dynamically tagged expression not allowed!", Expr
);
1080 end Check_Dynamically_Tagged_Expression
;
1082 --------------------------
1083 -- Check_Fully_Declared --
1084 --------------------------
1086 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
1088 if Ekind
(T
) = E_Incomplete_Type
then
1090 -- Ada 2005 (AI-50217): If the type is available through a limited
1091 -- with_clause, verify that its full view has been analyzed.
1093 if From_With_Type
(T
)
1094 and then Present
(Non_Limited_View
(T
))
1095 and then Ekind
(Non_Limited_View
(T
)) /= E_Incomplete_Type
1097 -- The non-limited view is fully declared
1102 ("premature usage of incomplete}", N
, First_Subtype
(T
));
1105 -- Need comments for these tests ???
1107 elsif Has_Private_Component
(T
)
1108 and then not Is_Generic_Type
(Root_Type
(T
))
1109 and then not In_Spec_Expression
1111 -- Special case: if T is the anonymous type created for a single
1112 -- task or protected object, use the name of the source object.
1114 if Is_Concurrent_Type
(T
)
1115 and then not Comes_From_Source
(T
)
1116 and then Nkind
(N
) = N_Object_Declaration
1118 Error_Msg_NE
("type of& has incomplete component", N
,
1119 Defining_Identifier
(N
));
1123 ("premature usage of incomplete}", N
, First_Subtype
(T
));
1126 end Check_Fully_Declared
;
1128 -------------------------
1129 -- Check_Nested_Access --
1130 -------------------------
1132 procedure Check_Nested_Access
(Ent
: Entity_Id
) is
1133 Scop
: constant Entity_Id
:= Current_Scope
;
1134 Current_Subp
: Entity_Id
;
1135 Enclosing
: Entity_Id
;
1138 -- Currently only enabled for VM back-ends for efficiency, should we
1139 -- enable it more systematically ???
1141 -- Check for Is_Imported needs commenting below ???
1143 if VM_Target
/= No_VM
1144 and then (Ekind
(Ent
) = E_Variable
1146 Ekind
(Ent
) = E_Constant
1148 Ekind
(Ent
) = E_Loop_Parameter
)
1149 and then Scope
(Ent
) /= Empty
1150 and then not Is_Library_Level_Entity
(Ent
)
1151 and then not Is_Imported
(Ent
)
1153 if Is_Subprogram
(Scop
)
1154 or else Is_Generic_Subprogram
(Scop
)
1155 or else Is_Entry
(Scop
)
1157 Current_Subp
:= Scop
;
1159 Current_Subp
:= Current_Subprogram
;
1162 Enclosing
:= Enclosing_Subprogram
(Ent
);
1164 if Enclosing
/= Empty
1165 and then Enclosing
/= Current_Subp
1167 Set_Has_Up_Level_Access
(Ent
, True);
1170 end Check_Nested_Access
;
1172 ----------------------------
1173 -- Check_Order_Dependence --
1174 ----------------------------
1176 procedure Check_Order_Dependence
is
1181 -- This could use comments ???
1183 for J
in 0 .. Actuals_In_Call
.Last
loop
1184 if Actuals_In_Call
.Table
(J
).Is_Writable
then
1185 Act1
:= Actuals_In_Call
.Table
(J
).Act
;
1187 if Nkind
(Act1
) = N_Attribute_Reference
then
1188 Act1
:= Prefix
(Act1
);
1191 for K
in 0 .. Actuals_In_Call
.Last
loop
1193 Act2
:= Actuals_In_Call
.Table
(K
).Act
;
1195 if Nkind
(Act2
) = N_Attribute_Reference
then
1196 Act2
:= Prefix
(Act2
);
1199 if Actuals_In_Call
.Table
(K
).Is_Writable
1206 elsif Denotes_Same_Object
(Act1
, Act2
)
1209 Error_Msg_N
("?,mighty suspicious!!!", Act1
);
1216 Actuals_In_Call
.Set_Last
(0);
1217 end Check_Order_Dependence
;
1219 ------------------------------------------
1220 -- Check_Potentially_Blocking_Operation --
1221 ------------------------------------------
1223 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
1226 -- N is one of the potentially blocking operations listed in 9.5.1(8).
1227 -- When pragma Detect_Blocking is active, the run time will raise
1228 -- Program_Error. Here we only issue a warning, since we generally
1229 -- support the use of potentially blocking operations in the absence
1232 -- Indirect blocking through a subprogram call cannot be diagnosed
1233 -- statically without interprocedural analysis, so we do not attempt
1236 S
:= Scope
(Current_Scope
);
1237 while Present
(S
) and then S
/= Standard_Standard
loop
1238 if Is_Protected_Type
(S
) then
1240 ("potentially blocking operation in protected operation?", N
);
1247 end Check_Potentially_Blocking_Operation
;
1249 ------------------------------
1250 -- Check_Unprotected_Access --
1251 ------------------------------
1253 procedure Check_Unprotected_Access
1257 Cont_Encl_Typ
: Entity_Id
;
1258 Pref_Encl_Typ
: Entity_Id
;
1260 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
;
1261 -- Check whether Obj is a private component of a protected object.
1262 -- Return the protected type where the component resides, Empty
1265 function Is_Public_Operation
return Boolean;
1266 -- Verify that the enclosing operation is callable from outside the
1267 -- protected object, to minimize false positives.
1269 ------------------------------
1270 -- Enclosing_Protected_Type --
1271 ------------------------------
1273 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
is
1275 if Is_Entity_Name
(Obj
) then
1277 Ent
: Entity_Id
:= Entity
(Obj
);
1280 -- The object can be a renaming of a private component, use
1281 -- the original record component.
1283 if Is_Prival
(Ent
) then
1284 Ent
:= Prival_Link
(Ent
);
1287 if Is_Protected_Type
(Scope
(Ent
)) then
1293 -- For indexed and selected components, recursively check the prefix
1295 if Nkind_In
(Obj
, N_Indexed_Component
, N_Selected_Component
) then
1296 return Enclosing_Protected_Type
(Prefix
(Obj
));
1298 -- The object does not denote a protected component
1303 end Enclosing_Protected_Type
;
1305 -------------------------
1306 -- Is_Public_Operation --
1307 -------------------------
1309 function Is_Public_Operation
return Boolean is
1316 and then S
/= Pref_Encl_Typ
1318 if Scope
(S
) = Pref_Encl_Typ
then
1319 E
:= First_Entity
(Pref_Encl_Typ
);
1321 and then E
/= First_Private_Entity
(Pref_Encl_Typ
)
1334 end Is_Public_Operation
;
1336 -- Start of processing for Check_Unprotected_Access
1339 if Nkind
(Expr
) = N_Attribute_Reference
1340 and then Attribute_Name
(Expr
) = Name_Unchecked_Access
1342 Cont_Encl_Typ
:= Enclosing_Protected_Type
(Context
);
1343 Pref_Encl_Typ
:= Enclosing_Protected_Type
(Prefix
(Expr
));
1345 -- Check whether we are trying to export a protected component to a
1346 -- context with an equal or lower access level.
1348 if Present
(Pref_Encl_Typ
)
1349 and then No
(Cont_Encl_Typ
)
1350 and then Is_Public_Operation
1351 and then Scope_Depth
(Pref_Encl_Typ
) >=
1352 Object_Access_Level
(Context
)
1355 ("?possible unprotected access to protected data", Expr
);
1358 end Check_Unprotected_Access
;
1364 procedure Check_VMS
(Construct
: Node_Id
) is
1366 if not OpenVMS_On_Target
then
1368 ("this construct is allowed only in Open'V'M'S", Construct
);
1372 ------------------------
1373 -- Collect_Interfaces --
1374 ------------------------
1376 procedure Collect_Interfaces
1378 Ifaces_List
: out Elist_Id
;
1379 Exclude_Parents
: Boolean := False;
1380 Use_Full_View
: Boolean := True)
1382 procedure Collect
(Typ
: Entity_Id
);
1383 -- Subsidiary subprogram used to traverse the whole list
1384 -- of directly and indirectly implemented interfaces
1390 procedure Collect
(Typ
: Entity_Id
) is
1391 Ancestor
: Entity_Id
;
1399 -- Handle private types
1402 and then Is_Private_Type
(Typ
)
1403 and then Present
(Full_View
(Typ
))
1405 Full_T
:= Full_View
(Typ
);
1408 -- Include the ancestor if we are generating the whole list of
1409 -- abstract interfaces.
1411 if Etype
(Full_T
) /= Typ
1413 -- Protect the frontend against wrong sources. For example:
1416 -- type A is tagged null record;
1417 -- type B is new A with private;
1418 -- type C is new A with private;
1420 -- type B is new C with null record;
1421 -- type C is new B with null record;
1424 and then Etype
(Full_T
) /= T
1426 Ancestor
:= Etype
(Full_T
);
1429 if Is_Interface
(Ancestor
)
1430 and then not Exclude_Parents
1432 Append_Unique_Elmt
(Ancestor
, Ifaces_List
);
1436 -- Traverse the graph of ancestor interfaces
1438 if Is_Non_Empty_List
(Abstract_Interface_List
(Full_T
)) then
1439 Id
:= First
(Abstract_Interface_List
(Full_T
));
1440 while Present
(Id
) loop
1441 Iface
:= Etype
(Id
);
1443 -- Protect against wrong uses. For example:
1444 -- type I is interface;
1445 -- type O is tagged null record;
1446 -- type Wrong is new I and O with null record; -- ERROR
1448 if Is_Interface
(Iface
) then
1450 and then Etype
(T
) /= T
1451 and then Interface_Present_In_Ancestor
(Etype
(T
), Iface
)
1456 Append_Unique_Elmt
(Iface
, Ifaces_List
);
1465 -- Start of processing for Collect_Interfaces
1468 pragma Assert
(Is_Tagged_Type
(T
) or else Is_Concurrent_Type
(T
));
1469 Ifaces_List
:= New_Elmt_List
;
1471 end Collect_Interfaces
;
1473 ----------------------------------
1474 -- Collect_Interface_Components --
1475 ----------------------------------
1477 procedure Collect_Interface_Components
1478 (Tagged_Type
: Entity_Id
;
1479 Components_List
: out Elist_Id
)
1481 procedure Collect
(Typ
: Entity_Id
);
1482 -- Subsidiary subprogram used to climb to the parents
1488 procedure Collect
(Typ
: Entity_Id
) is
1489 Tag_Comp
: Entity_Id
;
1490 Parent_Typ
: Entity_Id
;
1493 -- Handle private types
1495 if Present
(Full_View
(Etype
(Typ
))) then
1496 Parent_Typ
:= Full_View
(Etype
(Typ
));
1498 Parent_Typ
:= Etype
(Typ
);
1501 if Parent_Typ
/= Typ
1503 -- Protect the frontend against wrong sources. For example:
1506 -- type A is tagged null record;
1507 -- type B is new A with private;
1508 -- type C is new A with private;
1510 -- type B is new C with null record;
1511 -- type C is new B with null record;
1514 and then Parent_Typ
/= Tagged_Type
1516 Collect
(Parent_Typ
);
1519 -- Collect the components containing tags of secondary dispatch
1522 Tag_Comp
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
1523 while Present
(Tag_Comp
) loop
1524 pragma Assert
(Present
(Related_Type
(Tag_Comp
)));
1525 Append_Elmt
(Tag_Comp
, Components_List
);
1527 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
1531 -- Start of processing for Collect_Interface_Components
1534 pragma Assert
(Ekind
(Tagged_Type
) = E_Record_Type
1535 and then Is_Tagged_Type
(Tagged_Type
));
1537 Components_List
:= New_Elmt_List
;
1538 Collect
(Tagged_Type
);
1539 end Collect_Interface_Components
;
1541 -----------------------------
1542 -- Collect_Interfaces_Info --
1543 -----------------------------
1545 procedure Collect_Interfaces_Info
1547 Ifaces_List
: out Elist_Id
;
1548 Components_List
: out Elist_Id
;
1549 Tags_List
: out Elist_Id
)
1551 Comps_List
: Elist_Id
;
1552 Comp_Elmt
: Elmt_Id
;
1553 Comp_Iface
: Entity_Id
;
1554 Iface_Elmt
: Elmt_Id
;
1557 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
;
1558 -- Search for the secondary tag associated with the interface type
1559 -- Iface that is implemented by T.
1565 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
is
1568 if not Is_CPP_Class
(T
) then
1569 ADT
:= Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
))));
1571 ADT
:= Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
)));
1575 and then Is_Tag
(Node
(ADT
))
1576 and then Related_Type
(Node
(ADT
)) /= Iface
1578 -- Skip secondary dispatch table referencing thunks to user
1579 -- defined primitives covered by this interface.
1581 pragma Assert
(Has_Suffix
(Node
(ADT
), 'P'));
1584 -- Skip secondary dispatch tables of Ada types
1586 if not Is_CPP_Class
(T
) then
1588 -- Skip secondary dispatch table referencing thunks to
1589 -- predefined primitives.
1591 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Y'));
1594 -- Skip secondary dispatch table referencing user-defined
1595 -- primitives covered by this interface.
1597 pragma Assert
(Has_Suffix
(Node
(ADT
), 'D'));
1600 -- Skip secondary dispatch table referencing predefined
1603 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Z'));
1608 pragma Assert
(Is_Tag
(Node
(ADT
)));
1612 -- Start of processing for Collect_Interfaces_Info
1615 Collect_Interfaces
(T
, Ifaces_List
);
1616 Collect_Interface_Components
(T
, Comps_List
);
1618 -- Search for the record component and tag associated with each
1619 -- interface type of T.
1621 Components_List
:= New_Elmt_List
;
1622 Tags_List
:= New_Elmt_List
;
1624 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
1625 while Present
(Iface_Elmt
) loop
1626 Iface
:= Node
(Iface_Elmt
);
1628 -- Associate the primary tag component and the primary dispatch table
1629 -- with all the interfaces that are parents of T
1631 if Is_Ancestor
(Iface
, T
) then
1632 Append_Elmt
(First_Tag_Component
(T
), Components_List
);
1633 Append_Elmt
(Node
(First_Elmt
(Access_Disp_Table
(T
))), Tags_List
);
1635 -- Otherwise search for the tag component and secondary dispatch
1639 Comp_Elmt
:= First_Elmt
(Comps_List
);
1640 while Present
(Comp_Elmt
) loop
1641 Comp_Iface
:= Related_Type
(Node
(Comp_Elmt
));
1643 if Comp_Iface
= Iface
1644 or else Is_Ancestor
(Iface
, Comp_Iface
)
1646 Append_Elmt
(Node
(Comp_Elmt
), Components_List
);
1647 Append_Elmt
(Search_Tag
(Comp_Iface
), Tags_List
);
1651 Next_Elmt
(Comp_Elmt
);
1653 pragma Assert
(Present
(Comp_Elmt
));
1656 Next_Elmt
(Iface_Elmt
);
1658 end Collect_Interfaces_Info
;
1660 ----------------------------------
1661 -- Collect_Primitive_Operations --
1662 ----------------------------------
1664 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
1665 B_Type
: constant Entity_Id
:= Base_Type
(T
);
1666 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
1667 B_Scope
: Entity_Id
:= Scope
(B_Type
);
1671 Formal_Derived
: Boolean := False;
1675 -- For tagged types, the primitive operations are collected as they
1676 -- are declared, and held in an explicit list which is simply returned.
1678 if Is_Tagged_Type
(B_Type
) then
1679 return Primitive_Operations
(B_Type
);
1681 -- An untagged generic type that is a derived type inherits the
1682 -- primitive operations of its parent type. Other formal types only
1683 -- have predefined operators, which are not explicitly represented.
1685 elsif Is_Generic_Type
(B_Type
) then
1686 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
1687 and then Nkind
(Formal_Type_Definition
(B_Decl
))
1688 = N_Formal_Derived_Type_Definition
1690 Formal_Derived
:= True;
1692 return New_Elmt_List
;
1696 Op_List
:= New_Elmt_List
;
1698 if B_Scope
= Standard_Standard
then
1699 if B_Type
= Standard_String
then
1700 Append_Elmt
(Standard_Op_Concat
, Op_List
);
1702 elsif B_Type
= Standard_Wide_String
then
1703 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
1709 elsif (Is_Package_Or_Generic_Package
(B_Scope
)
1711 Nkind
(Parent
(Declaration_Node
(First_Subtype
(T
)))) /=
1713 or else Is_Derived_Type
(B_Type
)
1715 -- The primitive operations appear after the base type, except
1716 -- if the derivation happens within the private part of B_Scope
1717 -- and the type is a private type, in which case both the type
1718 -- and some primitive operations may appear before the base
1719 -- type, and the list of candidates starts after the type.
1721 if In_Open_Scopes
(B_Scope
)
1722 and then Scope
(T
) = B_Scope
1723 and then In_Private_Part
(B_Scope
)
1725 Id
:= Next_Entity
(T
);
1727 Id
:= Next_Entity
(B_Type
);
1730 while Present
(Id
) loop
1732 -- Note that generic formal subprograms are not
1733 -- considered to be primitive operations and thus
1734 -- are never inherited.
1736 if Is_Overloadable
(Id
)
1737 and then Nkind
(Parent
(Parent
(Id
)))
1738 not in N_Formal_Subprogram_Declaration
1742 if Base_Type
(Etype
(Id
)) = B_Type
then
1745 Formal
:= First_Formal
(Id
);
1746 while Present
(Formal
) loop
1747 if Base_Type
(Etype
(Formal
)) = B_Type
then
1751 elsif Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
1753 (Designated_Type
(Etype
(Formal
))) = B_Type
1759 Next_Formal
(Formal
);
1763 -- For a formal derived type, the only primitives are the
1764 -- ones inherited from the parent type. Operations appearing
1765 -- in the package declaration are not primitive for it.
1768 and then (not Formal_Derived
1769 or else Present
(Alias
(Id
)))
1771 -- In the special case of an equality operator aliased to
1772 -- an overriding dispatching equality belonging to the same
1773 -- type, we don't include it in the list of primitives.
1774 -- This avoids inheriting multiple equality operators when
1775 -- deriving from untagged private types whose full type is
1776 -- tagged, which can otherwise cause ambiguities. Note that
1777 -- this should only happen for this kind of untagged parent
1778 -- type, since normally dispatching operations are inherited
1779 -- using the type's Primitive_Operations list.
1781 if Chars
(Id
) = Name_Op_Eq
1782 and then Is_Dispatching_Operation
(Id
)
1783 and then Present
(Alias
(Id
))
1784 and then Is_Overriding_Operation
(Alias
(Id
))
1785 and then Base_Type
(Etype
(First_Entity
(Id
))) =
1786 Base_Type
(Etype
(First_Entity
(Alias
(Id
))))
1790 -- Include the subprogram in the list of primitives
1793 Append_Elmt
(Id
, Op_List
);
1800 -- For a type declared in System, some of its operations may
1801 -- appear in the target-specific extension to System.
1804 and then B_Scope
= RTU_Entity
(System
)
1805 and then Present_System_Aux
1807 B_Scope
:= System_Aux_Id
;
1808 Id
:= First_Entity
(System_Aux_Id
);
1814 end Collect_Primitive_Operations
;
1816 -----------------------------------
1817 -- Compile_Time_Constraint_Error --
1818 -----------------------------------
1820 function Compile_Time_Constraint_Error
1823 Ent
: Entity_Id
:= Empty
;
1824 Loc
: Source_Ptr
:= No_Location
;
1825 Warn
: Boolean := False) return Node_Id
1827 Msgc
: String (1 .. Msg
'Length + 2);
1828 -- Copy of message, with room for possible ? and ! at end
1838 -- A static constraint error in an instance body is not a fatal error.
1839 -- we choose to inhibit the message altogether, because there is no
1840 -- obvious node (for now) on which to post it. On the other hand the
1841 -- offending node must be replaced with a constraint_error in any case.
1843 -- No messages are generated if we already posted an error on this node
1845 if not Error_Posted
(N
) then
1846 if Loc
/= No_Location
then
1852 Msgc
(1 .. Msg
'Length) := Msg
;
1855 -- Message is a warning, even in Ada 95 case
1857 if Msg
(Msg
'Last) = '?' then
1860 -- In Ada 83, all messages are warnings. In the private part and
1861 -- the body of an instance, constraint_checks are only warnings.
1862 -- We also make this a warning if the Warn parameter is set.
1865 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
1871 elsif In_Instance_Not_Visible
then
1876 -- Otherwise we have a real error message (Ada 95 static case)
1877 -- and we make this an unconditional message. Note that in the
1878 -- warning case we do not make the message unconditional, it seems
1879 -- quite reasonable to delete messages like this (about exceptions
1880 -- that will be raised) in dead code.
1888 -- Should we generate a warning? The answer is not quite yes. The
1889 -- very annoying exception occurs in the case of a short circuit
1890 -- operator where the left operand is static and decisive. Climb
1891 -- parents to see if that is the case we have here. Conditional
1892 -- expressions with decisive conditions are a similar situation.
1900 -- And then with False as left operand
1902 if Nkind
(P
) = N_And_Then
1903 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1904 and then Is_False
(Expr_Value
(Left_Opnd
(P
)))
1909 -- OR ELSE with True as left operand
1911 elsif Nkind
(P
) = N_Or_Else
1912 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
1913 and then Is_True
(Expr_Value
(Left_Opnd
(P
)))
1918 -- Conditional expression
1920 elsif Nkind
(P
) = N_Conditional_Expression
then
1922 Cond
: constant Node_Id
:= First
(Expressions
(P
));
1923 Texp
: constant Node_Id
:= Next
(Cond
);
1924 Fexp
: constant Node_Id
:= Next
(Texp
);
1927 if Compile_Time_Known_Value
(Cond
) then
1929 -- Condition is True and we are in the right operand
1931 if Is_True
(Expr_Value
(Cond
))
1932 and then OldP
= Fexp
1937 -- Condition is False and we are in the left operand
1939 elsif Is_False
(Expr_Value
(Cond
))
1940 and then OldP
= Texp
1948 -- Special case for component association in aggregates, where
1949 -- we want to keep climbing up to the parent aggregate.
1951 elsif Nkind
(P
) = N_Component_Association
1952 and then Nkind
(Parent
(P
)) = N_Aggregate
1956 -- Keep going if within subexpression
1959 exit when Nkind
(P
) not in N_Subexpr
;
1964 if Present
(Ent
) then
1965 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
1967 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
1971 if Inside_Init_Proc
then
1973 ("\?& will be raised for objects of this type",
1974 N
, Standard_Constraint_Error
, Eloc
);
1977 ("\?& will be raised at run time",
1978 N
, Standard_Constraint_Error
, Eloc
);
1983 ("\static expression fails Constraint_Check", Eloc
);
1984 Set_Error_Posted
(N
);
1990 end Compile_Time_Constraint_Error
;
1992 -----------------------
1993 -- Conditional_Delay --
1994 -----------------------
1996 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
1998 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
1999 Set_Has_Delayed_Freeze
(New_Ent
);
2001 end Conditional_Delay
;
2003 -------------------------
2004 -- Copy_Parameter_List --
2005 -------------------------
2007 function Copy_Parameter_List
(Subp_Id
: Entity_Id
) return List_Id
is
2008 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
2013 if No
(First_Formal
(Subp_Id
)) then
2017 Formal
:= First_Formal
(Subp_Id
);
2018 while Present
(Formal
) loop
2020 (Make_Parameter_Specification
(Loc
,
2021 Defining_Identifier
=>
2022 Make_Defining_Identifier
(Sloc
(Formal
),
2023 Chars
=> Chars
(Formal
)),
2024 In_Present
=> In_Present
(Parent
(Formal
)),
2025 Out_Present
=> Out_Present
(Parent
(Formal
)),
2027 New_Reference_To
(Etype
(Formal
), Loc
),
2029 New_Copy_Tree
(Expression
(Parent
(Formal
)))),
2032 Next_Formal
(Formal
);
2037 end Copy_Parameter_List
;
2039 --------------------
2040 -- Current_Entity --
2041 --------------------
2043 -- The currently visible definition for a given identifier is the
2044 -- one most chained at the start of the visibility chain, i.e. the
2045 -- one that is referenced by the Node_Id value of the name of the
2046 -- given identifier.
2048 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
2050 return Get_Name_Entity_Id
(Chars
(N
));
2053 -----------------------------
2054 -- Current_Entity_In_Scope --
2055 -----------------------------
2057 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
2059 CS
: constant Entity_Id
:= Current_Scope
;
2061 Transient_Case
: constant Boolean := Scope_Is_Transient
;
2064 E
:= Get_Name_Entity_Id
(Chars
(N
));
2066 and then Scope
(E
) /= CS
2067 and then (not Transient_Case
or else Scope
(E
) /= Scope
(CS
))
2073 end Current_Entity_In_Scope
;
2079 function Current_Scope
return Entity_Id
is
2081 if Scope_Stack
.Last
= -1 then
2082 return Standard_Standard
;
2085 C
: constant Entity_Id
:=
2086 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
2091 return Standard_Standard
;
2097 ------------------------
2098 -- Current_Subprogram --
2099 ------------------------
2101 function Current_Subprogram
return Entity_Id
is
2102 Scop
: constant Entity_Id
:= Current_Scope
;
2104 if Is_Subprogram
(Scop
) or else Is_Generic_Subprogram
(Scop
) then
2107 return Enclosing_Subprogram
(Scop
);
2109 end Current_Subprogram
;
2111 ---------------------
2112 -- Defining_Entity --
2113 ---------------------
2115 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
2116 K
: constant Node_Kind
:= Nkind
(N
);
2117 Err
: Entity_Id
:= Empty
;
2122 N_Subprogram_Declaration |
2123 N_Abstract_Subprogram_Declaration |
2125 N_Package_Declaration |
2126 N_Subprogram_Renaming_Declaration |
2127 N_Subprogram_Body_Stub |
2128 N_Generic_Subprogram_Declaration |
2129 N_Generic_Package_Declaration |
2130 N_Formal_Subprogram_Declaration
2132 return Defining_Entity
(Specification
(N
));
2135 N_Component_Declaration |
2136 N_Defining_Program_Unit_Name |
2137 N_Discriminant_Specification |
2139 N_Entry_Declaration |
2140 N_Entry_Index_Specification |
2141 N_Exception_Declaration |
2142 N_Exception_Renaming_Declaration |
2143 N_Formal_Object_Declaration |
2144 N_Formal_Package_Declaration |
2145 N_Formal_Type_Declaration |
2146 N_Full_Type_Declaration |
2147 N_Implicit_Label_Declaration |
2148 N_Incomplete_Type_Declaration |
2149 N_Loop_Parameter_Specification |
2150 N_Number_Declaration |
2151 N_Object_Declaration |
2152 N_Object_Renaming_Declaration |
2153 N_Package_Body_Stub |
2154 N_Parameter_Specification |
2155 N_Private_Extension_Declaration |
2156 N_Private_Type_Declaration |
2158 N_Protected_Body_Stub |
2159 N_Protected_Type_Declaration |
2160 N_Single_Protected_Declaration |
2161 N_Single_Task_Declaration |
2162 N_Subtype_Declaration |
2165 N_Task_Type_Declaration
2167 return Defining_Identifier
(N
);
2170 return Defining_Entity
(Proper_Body
(N
));
2173 N_Function_Instantiation |
2174 N_Function_Specification |
2175 N_Generic_Function_Renaming_Declaration |
2176 N_Generic_Package_Renaming_Declaration |
2177 N_Generic_Procedure_Renaming_Declaration |
2179 N_Package_Instantiation |
2180 N_Package_Renaming_Declaration |
2181 N_Package_Specification |
2182 N_Procedure_Instantiation |
2183 N_Procedure_Specification
2186 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
2189 if Nkind
(Nam
) in N_Entity
then
2192 -- For Error, make up a name and attach to declaration
2193 -- so we can continue semantic analysis
2195 elsif Nam
= Error
then
2196 Err
:= Make_Temporary
(Sloc
(N
), 'T');
2197 Set_Defining_Unit_Name
(N
, Err
);
2200 -- If not an entity, get defining identifier
2203 return Defining_Identifier
(Nam
);
2207 when N_Block_Statement
=>
2208 return Entity
(Identifier
(N
));
2211 raise Program_Error
;
2214 end Defining_Entity
;
2216 --------------------------
2217 -- Denotes_Discriminant --
2218 --------------------------
2220 function Denotes_Discriminant
2222 Check_Concurrent
: Boolean := False) return Boolean
2226 if not Is_Entity_Name
(N
)
2227 or else No
(Entity
(N
))
2234 -- If we are checking for a protected type, the discriminant may have
2235 -- been rewritten as the corresponding discriminal of the original type
2236 -- or of the corresponding concurrent record, depending on whether we
2237 -- are in the spec or body of the protected type.
2239 return Ekind
(E
) = E_Discriminant
2242 and then Ekind
(E
) = E_In_Parameter
2243 and then Present
(Discriminal_Link
(E
))
2245 (Is_Concurrent_Type
(Scope
(Discriminal_Link
(E
)))
2247 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
2249 end Denotes_Discriminant
;
2251 -------------------------
2252 -- Denotes_Same_Object --
2253 -------------------------
2255 function Denotes_Same_Object
(A1
, A2
: Node_Id
) return Boolean is
2257 -- If we have entity names, then must be same entity
2259 if Is_Entity_Name
(A1
) then
2260 if Is_Entity_Name
(A2
) then
2261 return Entity
(A1
) = Entity
(A2
);
2266 -- No match if not same node kind
2268 elsif Nkind
(A1
) /= Nkind
(A2
) then
2271 -- For selected components, must have same prefix and selector
2273 elsif Nkind
(A1
) = N_Selected_Component
then
2274 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
))
2276 Entity
(Selector_Name
(A1
)) = Entity
(Selector_Name
(A2
));
2278 -- For explicit dereferences, prefixes must be same
2280 elsif Nkind
(A1
) = N_Explicit_Dereference
then
2281 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
));
2283 -- For indexed components, prefixes and all subscripts must be the same
2285 elsif Nkind
(A1
) = N_Indexed_Component
then
2286 if Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
2292 Indx1
:= First
(Expressions
(A1
));
2293 Indx2
:= First
(Expressions
(A2
));
2294 while Present
(Indx1
) loop
2296 -- Shouldn't we be checking that values are the same???
2298 if not Denotes_Same_Object
(Indx1
, Indx2
) then
2312 -- For slices, prefixes must match and bounds must match
2314 elsif Nkind
(A1
) = N_Slice
2315 and then Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
))
2318 Lo1
, Lo2
, Hi1
, Hi2
: Node_Id
;
2321 Get_Index_Bounds
(Etype
(A1
), Lo1
, Hi1
);
2322 Get_Index_Bounds
(Etype
(A2
), Lo2
, Hi2
);
2324 -- Check whether bounds are statically identical. There is no
2325 -- attempt to detect partial overlap of slices.
2327 -- What about an array and a slice of an array???
2329 return Denotes_Same_Object
(Lo1
, Lo2
)
2330 and then Denotes_Same_Object
(Hi1
, Hi2
);
2333 -- Literals will appear as indices. Isn't this where we should check
2334 -- Known_At_Compile_Time at least if we are generating warnings ???
2336 elsif Nkind
(A1
) = N_Integer_Literal
then
2337 return Intval
(A1
) = Intval
(A2
);
2342 end Denotes_Same_Object
;
2344 -------------------------
2345 -- Denotes_Same_Prefix --
2346 -------------------------
2348 function Denotes_Same_Prefix
(A1
, A2
: Node_Id
) return Boolean is
2351 if Is_Entity_Name
(A1
) then
2352 if Nkind_In
(A2
, N_Selected_Component
, N_Indexed_Component
)
2353 and then not Is_Access_Type
(Etype
(A1
))
2355 return Denotes_Same_Object
(A1
, Prefix
(A2
))
2356 or else Denotes_Same_Prefix
(A1
, Prefix
(A2
));
2361 elsif Is_Entity_Name
(A2
) then
2362 return Denotes_Same_Prefix
(A2
, A1
);
2364 elsif Nkind_In
(A1
, N_Selected_Component
, N_Indexed_Component
, N_Slice
)
2366 Nkind_In
(A2
, N_Selected_Component
, N_Indexed_Component
, N_Slice
)
2369 Root1
, Root2
: Node_Id
;
2370 Depth1
, Depth2
: Int
:= 0;
2373 Root1
:= Prefix
(A1
);
2374 while not Is_Entity_Name
(Root1
) loop
2376 (Root1
, N_Selected_Component
, N_Indexed_Component
)
2380 Root1
:= Prefix
(Root1
);
2383 Depth1
:= Depth1
+ 1;
2386 Root2
:= Prefix
(A2
);
2387 while not Is_Entity_Name
(Root2
) loop
2389 (Root2
, N_Selected_Component
, N_Indexed_Component
)
2393 Root2
:= Prefix
(Root2
);
2396 Depth2
:= Depth2
+ 1;
2399 -- If both have the same depth and they do not denote the same
2400 -- object, they are disjoint and not warning is needed.
2402 if Depth1
= Depth2
then
2405 elsif Depth1
> Depth2
then
2406 Root1
:= Prefix
(A1
);
2407 for I
in 1 .. Depth1
- Depth2
- 1 loop
2408 Root1
:= Prefix
(Root1
);
2411 return Denotes_Same_Object
(Root1
, A2
);
2414 Root2
:= Prefix
(A2
);
2415 for I
in 1 .. Depth2
- Depth1
- 1 loop
2416 Root2
:= Prefix
(Root2
);
2419 return Denotes_Same_Object
(A1
, Root2
);
2426 end Denotes_Same_Prefix
;
2428 ----------------------
2429 -- Denotes_Variable --
2430 ----------------------
2432 function Denotes_Variable
(N
: Node_Id
) return Boolean is
2434 return Is_Variable
(N
) and then Paren_Count
(N
) = 0;
2435 end Denotes_Variable
;
2437 -----------------------------
2438 -- Depends_On_Discriminant --
2439 -----------------------------
2441 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
2446 Get_Index_Bounds
(N
, L
, H
);
2447 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
2448 end Depends_On_Discriminant
;
2450 -------------------------
2451 -- Designate_Same_Unit --
2452 -------------------------
2454 function Designate_Same_Unit
2456 Name2
: Node_Id
) return Boolean
2458 K1
: constant Node_Kind
:= Nkind
(Name1
);
2459 K2
: constant Node_Kind
:= Nkind
(Name2
);
2461 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
2462 -- Returns the parent unit name node of a defining program unit name
2463 -- or the prefix if N is a selected component or an expanded name.
2465 function Select_Node
(N
: Node_Id
) return Node_Id
;
2466 -- Returns the defining identifier node of a defining program unit
2467 -- name or the selector node if N is a selected component or an
2474 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
2476 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
2488 function Select_Node
(N
: Node_Id
) return Node_Id
is
2490 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
2491 return Defining_Identifier
(N
);
2494 return Selector_Name
(N
);
2498 -- Start of processing for Designate_Next_Unit
2501 if (K1
= N_Identifier
or else
2502 K1
= N_Defining_Identifier
)
2504 (K2
= N_Identifier
or else
2505 K2
= N_Defining_Identifier
)
2507 return Chars
(Name1
) = Chars
(Name2
);
2510 (K1
= N_Expanded_Name
or else
2511 K1
= N_Selected_Component
or else
2512 K1
= N_Defining_Program_Unit_Name
)
2514 (K2
= N_Expanded_Name
or else
2515 K2
= N_Selected_Component
or else
2516 K2
= N_Defining_Program_Unit_Name
)
2519 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
2521 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
2526 end Designate_Same_Unit
;
2528 --------------------------
2529 -- Enclosing_CPP_Parent --
2530 --------------------------
2532 function Enclosing_CPP_Parent
(Typ
: Entity_Id
) return Entity_Id
is
2533 Parent_Typ
: Entity_Id
:= Typ
;
2536 while not Is_CPP_Class
(Parent_Typ
)
2537 and then Etype
(Parent_Typ
) /= Parent_Typ
2539 Parent_Typ
:= Etype
(Parent_Typ
);
2541 if Is_Private_Type
(Parent_Typ
) then
2542 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
2546 pragma Assert
(Is_CPP_Class
(Parent_Typ
));
2548 end Enclosing_CPP_Parent
;
2550 ----------------------------
2551 -- Enclosing_Generic_Body --
2552 ----------------------------
2554 function Enclosing_Generic_Body
2555 (N
: Node_Id
) return Node_Id
2563 while Present
(P
) loop
2564 if Nkind
(P
) = N_Package_Body
2565 or else Nkind
(P
) = N_Subprogram_Body
2567 Spec
:= Corresponding_Spec
(P
);
2569 if Present
(Spec
) then
2570 Decl
:= Unit_Declaration_Node
(Spec
);
2572 if Nkind
(Decl
) = N_Generic_Package_Declaration
2573 or else Nkind
(Decl
) = N_Generic_Subprogram_Declaration
2584 end Enclosing_Generic_Body
;
2586 ----------------------------
2587 -- Enclosing_Generic_Unit --
2588 ----------------------------
2590 function Enclosing_Generic_Unit
2591 (N
: Node_Id
) return Node_Id
2599 while Present
(P
) loop
2600 if Nkind
(P
) = N_Generic_Package_Declaration
2601 or else Nkind
(P
) = N_Generic_Subprogram_Declaration
2605 elsif Nkind
(P
) = N_Package_Body
2606 or else Nkind
(P
) = N_Subprogram_Body
2608 Spec
:= Corresponding_Spec
(P
);
2610 if Present
(Spec
) then
2611 Decl
:= Unit_Declaration_Node
(Spec
);
2613 if Nkind
(Decl
) = N_Generic_Package_Declaration
2614 or else Nkind
(Decl
) = N_Generic_Subprogram_Declaration
2625 end Enclosing_Generic_Unit
;
2627 -------------------------------
2628 -- Enclosing_Lib_Unit_Entity --
2629 -------------------------------
2631 function Enclosing_Lib_Unit_Entity
return Entity_Id
is
2632 Unit_Entity
: Entity_Id
;
2635 -- Look for enclosing library unit entity by following scope links.
2636 -- Equivalent to, but faster than indexing through the scope stack.
2638 Unit_Entity
:= Current_Scope
;
2639 while (Present
(Scope
(Unit_Entity
))
2640 and then Scope
(Unit_Entity
) /= Standard_Standard
)
2641 and not Is_Child_Unit
(Unit_Entity
)
2643 Unit_Entity
:= Scope
(Unit_Entity
);
2647 end Enclosing_Lib_Unit_Entity
;
2649 -----------------------------
2650 -- Enclosing_Lib_Unit_Node --
2651 -----------------------------
2653 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
2654 Current_Node
: Node_Id
;
2658 while Present
(Current_Node
)
2659 and then Nkind
(Current_Node
) /= N_Compilation_Unit
2661 Current_Node
:= Parent
(Current_Node
);
2664 if Nkind
(Current_Node
) /= N_Compilation_Unit
then
2668 return Current_Node
;
2669 end Enclosing_Lib_Unit_Node
;
2671 --------------------------
2672 -- Enclosing_Subprogram --
2673 --------------------------
2675 function Enclosing_Subprogram
(E
: Entity_Id
) return Entity_Id
is
2676 Dynamic_Scope
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(E
);
2679 if Dynamic_Scope
= Standard_Standard
then
2682 elsif Dynamic_Scope
= Empty
then
2685 elsif Ekind
(Dynamic_Scope
) = E_Subprogram_Body
then
2686 return Corresponding_Spec
(Parent
(Parent
(Dynamic_Scope
)));
2688 elsif Ekind
(Dynamic_Scope
) = E_Block
2689 or else Ekind
(Dynamic_Scope
) = E_Return_Statement
2691 return Enclosing_Subprogram
(Dynamic_Scope
);
2693 elsif Ekind
(Dynamic_Scope
) = E_Task_Type
then
2694 return Get_Task_Body_Procedure
(Dynamic_Scope
);
2696 -- No body is generated if the protected operation is eliminated
2698 elsif Convention
(Dynamic_Scope
) = Convention_Protected
2699 and then not Is_Eliminated
(Dynamic_Scope
)
2700 and then Present
(Protected_Body_Subprogram
(Dynamic_Scope
))
2702 return Protected_Body_Subprogram
(Dynamic_Scope
);
2705 return Dynamic_Scope
;
2707 end Enclosing_Subprogram
;
2709 ------------------------
2710 -- Ensure_Freeze_Node --
2711 ------------------------
2713 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
2717 if No
(Freeze_Node
(E
)) then
2718 FN
:= Make_Freeze_Entity
(Sloc
(E
));
2719 Set_Has_Delayed_Freeze
(E
);
2720 Set_Freeze_Node
(E
, FN
);
2721 Set_Access_Types_To_Process
(FN
, No_Elist
);
2722 Set_TSS_Elist
(FN
, No_Elist
);
2725 end Ensure_Freeze_Node
;
2731 procedure Enter_Name
(Def_Id
: Entity_Id
) is
2732 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
2733 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
2734 S
: constant Entity_Id
:= Current_Scope
;
2737 Generate_Definition
(Def_Id
);
2739 -- Add new name to current scope declarations. Check for duplicate
2740 -- declaration, which may or may not be a genuine error.
2744 -- Case of previous entity entered because of a missing declaration
2745 -- or else a bad subtype indication. Best is to use the new entity,
2746 -- and make the previous one invisible.
2748 if Etype
(E
) = Any_Type
then
2749 Set_Is_Immediately_Visible
(E
, False);
2751 -- Case of renaming declaration constructed for package instances.
2752 -- if there is an explicit declaration with the same identifier,
2753 -- the renaming is not immediately visible any longer, but remains
2754 -- visible through selected component notation.
2756 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
2757 and then not Comes_From_Source
(E
)
2759 Set_Is_Immediately_Visible
(E
, False);
2761 -- The new entity may be the package renaming, which has the same
2762 -- same name as a generic formal which has been seen already.
2764 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
2765 and then not Comes_From_Source
(Def_Id
)
2767 Set_Is_Immediately_Visible
(E
, False);
2769 -- For a fat pointer corresponding to a remote access to subprogram,
2770 -- we use the same identifier as the RAS type, so that the proper
2771 -- name appears in the stub. This type is only retrieved through
2772 -- the RAS type and never by visibility, and is not added to the
2773 -- visibility list (see below).
2775 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
2776 and then Present
(Corresponding_Remote_Type
(Def_Id
))
2780 -- A controller component for a type extension overrides the
2781 -- inherited component.
2783 elsif Chars
(E
) = Name_uController
then
2786 -- Case of an implicit operation or derived literal. The new entity
2787 -- hides the implicit one, which is removed from all visibility,
2788 -- i.e. the entity list of its scope, and homonym chain of its name.
2790 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
2791 or else Is_Internal
(E
)
2795 Prev_Vis
: Entity_Id
;
2796 Decl
: constant Node_Id
:= Parent
(E
);
2799 -- If E is an implicit declaration, it cannot be the first
2800 -- entity in the scope.
2802 Prev
:= First_Entity
(Current_Scope
);
2803 while Present
(Prev
)
2804 and then Next_Entity
(Prev
) /= E
2811 -- If E is not on the entity chain of the current scope,
2812 -- it is an implicit declaration in the generic formal
2813 -- part of a generic subprogram. When analyzing the body,
2814 -- the generic formals are visible but not on the entity
2815 -- chain of the subprogram. The new entity will become
2816 -- the visible one in the body.
2819 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
2823 Set_Next_Entity
(Prev
, Next_Entity
(E
));
2825 if No
(Next_Entity
(Prev
)) then
2826 Set_Last_Entity
(Current_Scope
, Prev
);
2829 if E
= Current_Entity
(E
) then
2833 Prev_Vis
:= Current_Entity
(E
);
2834 while Homonym
(Prev_Vis
) /= E
loop
2835 Prev_Vis
:= Homonym
(Prev_Vis
);
2839 if Present
(Prev_Vis
) then
2841 -- Skip E in the visibility chain
2843 Set_Homonym
(Prev_Vis
, Homonym
(E
));
2846 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
2851 -- This section of code could use a comment ???
2853 elsif Present
(Etype
(E
))
2854 and then Is_Concurrent_Type
(Etype
(E
))
2859 -- If the homograph is a protected component renaming, it should not
2860 -- be hiding the current entity. Such renamings are treated as weak
2863 elsif Is_Prival
(E
) then
2864 Set_Is_Immediately_Visible
(E
, False);
2866 -- In this case the current entity is a protected component renaming.
2867 -- Perform minimal decoration by setting the scope and return since
2868 -- the prival should not be hiding other visible entities.
2870 elsif Is_Prival
(Def_Id
) then
2871 Set_Scope
(Def_Id
, Current_Scope
);
2874 -- Analogous to privals, the discriminal generated for an entry
2875 -- index parameter acts as a weak declaration. Perform minimal
2876 -- decoration to avoid bogus errors.
2878 elsif Is_Discriminal
(Def_Id
)
2879 and then Ekind
(Discriminal_Link
(Def_Id
)) = E_Entry_Index_Parameter
2881 Set_Scope
(Def_Id
, Current_Scope
);
2884 -- In the body or private part of an instance, a type extension
2885 -- may introduce a component with the same name as that of an
2886 -- actual. The legality rule is not enforced, but the semantics
2887 -- of the full type with two components of the same name are not
2888 -- clear at this point ???
2890 elsif In_Instance_Not_Visible
then
2893 -- When compiling a package body, some child units may have become
2894 -- visible. They cannot conflict with local entities that hide them.
2896 elsif Is_Child_Unit
(E
)
2897 and then In_Open_Scopes
(Scope
(E
))
2898 and then not Is_Immediately_Visible
(E
)
2902 -- Conversely, with front-end inlining we may compile the parent
2903 -- body first, and a child unit subsequently. The context is now
2904 -- the parent spec, and body entities are not visible.
2906 elsif Is_Child_Unit
(Def_Id
)
2907 and then Is_Package_Body_Entity
(E
)
2908 and then not In_Package_Body
(Current_Scope
)
2912 -- Case of genuine duplicate declaration
2915 Error_Msg_Sloc
:= Sloc
(E
);
2917 -- If the previous declaration is an incomplete type declaration
2918 -- this may be an attempt to complete it with a private type.
2919 -- The following avoids confusing cascaded errors.
2921 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
2922 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
2925 ("incomplete type cannot be completed with a private " &
2926 "declaration", Parent
(Def_Id
));
2927 Set_Is_Immediately_Visible
(E
, False);
2928 Set_Full_View
(E
, Def_Id
);
2930 -- An inherited component of a record conflicts with a new
2931 -- discriminant. The discriminant is inserted first in the scope,
2932 -- but the error should be posted on it, not on the component.
2934 elsif Ekind
(E
) = E_Discriminant
2935 and then Present
(Scope
(Def_Id
))
2936 and then Scope
(Def_Id
) /= Current_Scope
2938 Error_Msg_Sloc
:= Sloc
(Def_Id
);
2939 Error_Msg_N
("& conflicts with declaration#", E
);
2942 -- If the name of the unit appears in its own context clause,
2943 -- a dummy package with the name has already been created, and
2944 -- the error emitted. Try to continue quietly.
2946 elsif Error_Posted
(E
)
2947 and then Sloc
(E
) = No_Location
2948 and then Nkind
(Parent
(E
)) = N_Package_Specification
2949 and then Current_Scope
= Standard_Standard
2951 Set_Scope
(Def_Id
, Current_Scope
);
2955 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
2957 -- Avoid cascaded messages with duplicate components in
2960 if Ekind_In
(E
, E_Component
, E_Discriminant
) then
2965 if Nkind
(Parent
(Parent
(Def_Id
))) =
2966 N_Generic_Subprogram_Declaration
2968 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
2970 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
2973 -- If entity is in standard, then we are in trouble, because
2974 -- it means that we have a library package with a duplicated
2975 -- name. That's hard to recover from, so abort!
2977 if S
= Standard_Standard
then
2978 raise Unrecoverable_Error
;
2980 -- Otherwise we continue with the declaration. Having two
2981 -- identical declarations should not cause us too much trouble!
2989 -- If we fall through, declaration is OK , or OK enough to continue
2991 -- If Def_Id is a discriminant or a record component we are in the
2992 -- midst of inheriting components in a derived record definition.
2993 -- Preserve their Ekind and Etype.
2995 if Ekind_In
(Def_Id
, E_Discriminant
, E_Component
) then
2998 -- If a type is already set, leave it alone (happens whey a type
2999 -- declaration is reanalyzed following a call to the optimizer)
3001 elsif Present
(Etype
(Def_Id
)) then
3004 -- Otherwise, the kind E_Void insures that premature uses of the entity
3005 -- will be detected. Any_Type insures that no cascaded errors will occur
3008 Set_Ekind
(Def_Id
, E_Void
);
3009 Set_Etype
(Def_Id
, Any_Type
);
3012 -- Inherited discriminants and components in derived record types are
3013 -- immediately visible. Itypes are not.
3015 if Ekind_In
(Def_Id
, E_Discriminant
, E_Component
)
3016 or else (No
(Corresponding_Remote_Type
(Def_Id
))
3017 and then not Is_Itype
(Def_Id
))
3019 Set_Is_Immediately_Visible
(Def_Id
);
3020 Set_Current_Entity
(Def_Id
);
3023 Set_Homonym
(Def_Id
, C
);
3024 Append_Entity
(Def_Id
, S
);
3025 Set_Public_Status
(Def_Id
);
3027 -- Warn if new entity hides an old one
3029 if Warn_On_Hiding
and then Present
(C
)
3031 -- Don't warn for record components since they always have a well
3032 -- defined scope which does not confuse other uses. Note that in
3033 -- some cases, Ekind has not been set yet.
3035 and then Ekind
(C
) /= E_Component
3036 and then Ekind
(C
) /= E_Discriminant
3037 and then Nkind
(Parent
(C
)) /= N_Component_Declaration
3038 and then Ekind
(Def_Id
) /= E_Component
3039 and then Ekind
(Def_Id
) /= E_Discriminant
3040 and then Nkind
(Parent
(Def_Id
)) /= N_Component_Declaration
3042 -- Don't warn for one character variables. It is too common to use
3043 -- such variables as locals and will just cause too many false hits.
3045 and then Length_Of_Name
(Chars
(C
)) /= 1
3047 -- Don't warn for non-source entities
3049 and then Comes_From_Source
(C
)
3050 and then Comes_From_Source
(Def_Id
)
3052 -- Don't warn unless entity in question is in extended main source
3054 and then In_Extended_Main_Source_Unit
(Def_Id
)
3056 -- Finally, the hidden entity must be either immediately visible
3057 -- or use visible (from a used package)
3060 (Is_Immediately_Visible
(C
)
3062 Is_Potentially_Use_Visible
(C
))
3064 Error_Msg_Sloc
:= Sloc
(C
);
3065 Error_Msg_N
("declaration hides &#?", Def_Id
);
3069 --------------------------
3070 -- Explain_Limited_Type --
3071 --------------------------
3073 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
3077 -- For array, component type must be limited
3079 if Is_Array_Type
(T
) then
3080 Error_Msg_Node_2
:= T
;
3082 ("\component type& of type& is limited", N
, Component_Type
(T
));
3083 Explain_Limited_Type
(Component_Type
(T
), N
);
3085 elsif Is_Record_Type
(T
) then
3087 -- No need for extra messages if explicit limited record
3089 if Is_Limited_Record
(Base_Type
(T
)) then
3093 -- Otherwise find a limited component. Check only components that
3094 -- come from source, or inherited components that appear in the
3095 -- source of the ancestor.
3097 C
:= First_Component
(T
);
3098 while Present
(C
) loop
3099 if Is_Limited_Type
(Etype
(C
))
3101 (Comes_From_Source
(C
)
3103 (Present
(Original_Record_Component
(C
))
3105 Comes_From_Source
(Original_Record_Component
(C
))))
3107 Error_Msg_Node_2
:= T
;
3108 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
3109 Explain_Limited_Type
(Etype
(C
), N
);
3116 -- The type may be declared explicitly limited, even if no component
3117 -- of it is limited, in which case we fall out of the loop.
3120 end Explain_Limited_Type
;
3126 procedure Find_Actual
3128 Formal
: out Entity_Id
;
3131 Parnt
: constant Node_Id
:= Parent
(N
);
3135 if (Nkind
(Parnt
) = N_Indexed_Component
3137 Nkind
(Parnt
) = N_Selected_Component
)
3138 and then N
= Prefix
(Parnt
)
3140 Find_Actual
(Parnt
, Formal
, Call
);
3143 elsif Nkind
(Parnt
) = N_Parameter_Association
3144 and then N
= Explicit_Actual_Parameter
(Parnt
)
3146 Call
:= Parent
(Parnt
);
3148 elsif Nkind
(Parnt
) = N_Procedure_Call_Statement
then
3157 -- If we have a call to a subprogram look for the parameter. Note that
3158 -- we exclude overloaded calls, since we don't know enough to be sure
3159 -- of giving the right answer in this case.
3161 if Is_Entity_Name
(Name
(Call
))
3162 and then Present
(Entity
(Name
(Call
)))
3163 and then Is_Overloadable
(Entity
(Name
(Call
)))
3164 and then not Is_Overloaded
(Name
(Call
))
3166 -- Fall here if we are definitely a parameter
3168 Actual
:= First_Actual
(Call
);
3169 Formal
:= First_Formal
(Entity
(Name
(Call
)));
3170 while Present
(Formal
) and then Present
(Actual
) loop
3174 Actual
:= Next_Actual
(Actual
);
3175 Formal
:= Next_Formal
(Formal
);
3180 -- Fall through here if we did not find matching actual
3186 ---------------------------
3187 -- Find_Body_Discriminal --
3188 ---------------------------
3190 function Find_Body_Discriminal
3191 (Spec_Discriminant
: Entity_Id
) return Entity_Id
3193 pragma Assert
(Is_Concurrent_Record_Type
(Scope
(Spec_Discriminant
)));
3195 Tsk
: constant Entity_Id
:=
3196 Corresponding_Concurrent_Type
(Scope
(Spec_Discriminant
));
3200 -- Find discriminant of original concurrent type, and use its current
3201 -- discriminal, which is the renaming within the task/protected body.
3203 Disc
:= First_Discriminant
(Tsk
);
3204 while Present
(Disc
) loop
3205 if Chars
(Disc
) = Chars
(Spec_Discriminant
) then
3206 return Discriminal
(Disc
);
3209 Next_Discriminant
(Disc
);
3212 -- That loop should always succeed in finding a matching entry and
3213 -- returning. Fatal error if not.
3215 raise Program_Error
;
3216 end Find_Body_Discriminal
;
3218 -------------------------------------
3219 -- Find_Corresponding_Discriminant --
3220 -------------------------------------
3222 function Find_Corresponding_Discriminant
3224 Typ
: Entity_Id
) return Entity_Id
3226 Par_Disc
: Entity_Id
;
3227 Old_Disc
: Entity_Id
;
3228 New_Disc
: Entity_Id
;
3231 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
3233 -- The original type may currently be private, and the discriminant
3234 -- only appear on its full view.
3236 if Is_Private_Type
(Scope
(Par_Disc
))
3237 and then not Has_Discriminants
(Scope
(Par_Disc
))
3238 and then Present
(Full_View
(Scope
(Par_Disc
)))
3240 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
3242 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
3245 if Is_Class_Wide_Type
(Typ
) then
3246 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
3248 New_Disc
:= First_Discriminant
(Typ
);
3251 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
3252 if Old_Disc
= Par_Disc
then
3255 Next_Discriminant
(Old_Disc
);
3256 Next_Discriminant
(New_Disc
);
3260 -- Should always find it
3262 raise Program_Error
;
3263 end Find_Corresponding_Discriminant
;
3265 --------------------------
3266 -- Find_Overlaid_Entity --
3267 --------------------------
3269 procedure Find_Overlaid_Entity
3271 Ent
: out Entity_Id
;
3277 -- We are looking for one of the two following forms:
3279 -- for X'Address use Y'Address
3283 -- Const : constant Address := expr;
3285 -- for X'Address use Const;
3287 -- In the second case, the expr is either Y'Address, or recursively a
3288 -- constant that eventually references Y'Address.
3293 if Nkind
(N
) = N_Attribute_Definition_Clause
3294 and then Chars
(N
) = Name_Address
3296 Expr
:= Expression
(N
);
3298 -- This loop checks the form of the expression for Y'Address,
3299 -- using recursion to deal with intermediate constants.
3302 -- Check for Y'Address
3304 if Nkind
(Expr
) = N_Attribute_Reference
3305 and then Attribute_Name
(Expr
) = Name_Address
3307 Expr
:= Prefix
(Expr
);
3310 -- Check for Const where Const is a constant entity
3312 elsif Is_Entity_Name
(Expr
)
3313 and then Ekind
(Entity
(Expr
)) = E_Constant
3315 Expr
:= Constant_Value
(Entity
(Expr
));
3317 -- Anything else does not need checking
3324 -- This loop checks the form of the prefix for an entity,
3325 -- using recursion to deal with intermediate components.
3328 -- Check for Y where Y is an entity
3330 if Is_Entity_Name
(Expr
) then
3331 Ent
:= Entity
(Expr
);
3334 -- Check for components
3337 Nkind_In
(Expr
, N_Selected_Component
, N_Indexed_Component
) then
3339 Expr
:= Prefix
(Expr
);
3342 -- Anything else does not need checking
3349 end Find_Overlaid_Entity
;
3351 -------------------------
3352 -- Find_Parameter_Type --
3353 -------------------------
3355 function Find_Parameter_Type
(Param
: Node_Id
) return Entity_Id
is
3357 if Nkind
(Param
) /= N_Parameter_Specification
then
3360 -- For an access parameter, obtain the type from the formal entity
3361 -- itself, because access to subprogram nodes do not carry a type.
3362 -- Shouldn't we always use the formal entity ???
3364 elsif Nkind
(Parameter_Type
(Param
)) = N_Access_Definition
then
3365 return Etype
(Defining_Identifier
(Param
));
3368 return Etype
(Parameter_Type
(Param
));
3370 end Find_Parameter_Type
;
3372 -----------------------------
3373 -- Find_Static_Alternative --
3374 -----------------------------
3376 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
3377 Expr
: constant Node_Id
:= Expression
(N
);
3378 Val
: constant Uint
:= Expr_Value
(Expr
);
3383 Alt
:= First
(Alternatives
(N
));
3386 if Nkind
(Alt
) /= N_Pragma
then
3387 Choice
:= First
(Discrete_Choices
(Alt
));
3388 while Present
(Choice
) loop
3390 -- Others choice, always matches
3392 if Nkind
(Choice
) = N_Others_Choice
then
3395 -- Range, check if value is in the range
3397 elsif Nkind
(Choice
) = N_Range
then
3399 Val
>= Expr_Value
(Low_Bound
(Choice
))
3401 Val
<= Expr_Value
(High_Bound
(Choice
));
3403 -- Choice is a subtype name. Note that we know it must
3404 -- be a static subtype, since otherwise it would have
3405 -- been diagnosed as illegal.
3407 elsif Is_Entity_Name
(Choice
)
3408 and then Is_Type
(Entity
(Choice
))
3410 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
),
3411 Assume_Valid
=> False);
3413 -- Choice is a subtype indication
3415 elsif Nkind
(Choice
) = N_Subtype_Indication
then
3417 C
: constant Node_Id
:= Constraint
(Choice
);
3418 R
: constant Node_Id
:= Range_Expression
(C
);
3422 Val
>= Expr_Value
(Low_Bound
(R
))
3424 Val
<= Expr_Value
(High_Bound
(R
));
3427 -- Choice is a simple expression
3430 exit Search
when Val
= Expr_Value
(Choice
);
3438 pragma Assert
(Present
(Alt
));
3441 -- The above loop *must* terminate by finding a match, since
3442 -- we know the case statement is valid, and the value of the
3443 -- expression is known at compile time. When we fall out of
3444 -- the loop, Alt points to the alternative that we know will
3445 -- be selected at run time.
3448 end Find_Static_Alternative
;
3454 function First_Actual
(Node
: Node_Id
) return Node_Id
is
3458 if No
(Parameter_Associations
(Node
)) then
3462 N
:= First
(Parameter_Associations
(Node
));
3464 if Nkind
(N
) = N_Parameter_Association
then
3465 return First_Named_Actual
(Node
);
3471 -------------------------
3472 -- Full_Qualified_Name --
3473 -------------------------
3475 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
3477 pragma Warnings
(Off
, Res
);
3479 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
;
3480 -- Compute recursively the qualified name without NUL at the end
3482 ----------------------------------
3483 -- Internal_Full_Qualified_Name --
3484 ----------------------------------
3486 function Internal_Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
3487 Ent
: Entity_Id
:= E
;
3488 Parent_Name
: String_Id
:= No_String
;
3491 -- Deals properly with child units
3493 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
3494 Ent
:= Defining_Identifier
(Ent
);
3497 -- Compute qualification recursively (only "Standard" has no scope)
3499 if Present
(Scope
(Scope
(Ent
))) then
3500 Parent_Name
:= Internal_Full_Qualified_Name
(Scope
(Ent
));
3503 -- Every entity should have a name except some expanded blocks
3504 -- don't bother about those.
3506 if Chars
(Ent
) = No_Name
then
3510 -- Add a period between Name and qualification
3512 if Parent_Name
/= No_String
then
3513 Start_String
(Parent_Name
);
3514 Store_String_Char
(Get_Char_Code
('.'));
3520 -- Generates the entity name in upper case
3522 Get_Decoded_Name_String
(Chars
(Ent
));
3524 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
3526 end Internal_Full_Qualified_Name
;
3528 -- Start of processing for Full_Qualified_Name
3531 Res
:= Internal_Full_Qualified_Name
(E
);
3532 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
3534 end Full_Qualified_Name
;
3536 -----------------------
3537 -- Gather_Components --
3538 -----------------------
3540 procedure Gather_Components
3542 Comp_List
: Node_Id
;
3543 Governed_By
: List_Id
;
3545 Report_Errors
: out Boolean)
3549 Discrete_Choice
: Node_Id
;
3550 Comp_Item
: Node_Id
;
3552 Discrim
: Entity_Id
;
3553 Discrim_Name
: Node_Id
;
3554 Discrim_Value
: Node_Id
;
3557 Report_Errors
:= False;
3559 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
3562 elsif Present
(Component_Items
(Comp_List
)) then
3563 Comp_Item
:= First
(Component_Items
(Comp_List
));
3569 while Present
(Comp_Item
) loop
3571 -- Skip the tag of a tagged record, the interface tags, as well
3572 -- as all items that are not user components (anonymous types,
3573 -- rep clauses, Parent field, controller field).
3575 if Nkind
(Comp_Item
) = N_Component_Declaration
then
3577 Comp
: constant Entity_Id
:= Defining_Identifier
(Comp_Item
);
3579 if not Is_Tag
(Comp
)
3580 and then Chars
(Comp
) /= Name_uParent
3581 and then Chars
(Comp
) /= Name_uController
3583 Append_Elmt
(Comp
, Into
);
3591 if No
(Variant_Part
(Comp_List
)) then
3594 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
3595 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
3598 -- Look for the discriminant that governs this variant part.
3599 -- The discriminant *must* be in the Governed_By List
3601 Assoc
:= First
(Governed_By
);
3602 Find_Constraint
: loop
3603 Discrim
:= First
(Choices
(Assoc
));
3604 exit Find_Constraint
when Chars
(Discrim_Name
) = Chars
(Discrim
)
3605 or else (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
3607 Chars
(Corresponding_Discriminant
(Entity
(Discrim
)))
3608 = Chars
(Discrim_Name
))
3609 or else Chars
(Original_Record_Component
(Entity
(Discrim
)))
3610 = Chars
(Discrim_Name
);
3612 if No
(Next
(Assoc
)) then
3613 if not Is_Constrained
(Typ
)
3614 and then Is_Derived_Type
(Typ
)
3615 and then Present
(Stored_Constraint
(Typ
))
3617 -- If the type is a tagged type with inherited discriminants,
3618 -- use the stored constraint on the parent in order to find
3619 -- the values of discriminants that are otherwise hidden by an
3620 -- explicit constraint. Renamed discriminants are handled in
3623 -- If several parent discriminants are renamed by a single
3624 -- discriminant of the derived type, the call to obtain the
3625 -- Corresponding_Discriminant field only retrieves the last
3626 -- of them. We recover the constraint on the others from the
3627 -- Stored_Constraint as well.
3634 D
:= First_Discriminant
(Etype
(Typ
));
3635 C
:= First_Elmt
(Stored_Constraint
(Typ
));
3636 while Present
(D
) and then Present
(C
) loop
3637 if Chars
(Discrim_Name
) = Chars
(D
) then
3638 if Is_Entity_Name
(Node
(C
))
3639 and then Entity
(Node
(C
)) = Entity
(Discrim
)
3641 -- D is renamed by Discrim, whose value is given in
3648 Make_Component_Association
(Sloc
(Typ
),
3650 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
3651 Duplicate_Subexpr_No_Checks
(Node
(C
)));
3653 exit Find_Constraint
;
3656 Next_Discriminant
(D
);
3663 if No
(Next
(Assoc
)) then
3664 Error_Msg_NE
(" missing value for discriminant&",
3665 First
(Governed_By
), Discrim_Name
);
3666 Report_Errors
:= True;
3671 end loop Find_Constraint
;
3673 Discrim_Value
:= Expression
(Assoc
);
3675 if not Is_OK_Static_Expression
(Discrim_Value
) then
3677 ("value for discriminant & must be static!",
3678 Discrim_Value
, Discrim
);
3679 Why_Not_Static
(Discrim_Value
);
3680 Report_Errors
:= True;
3684 Search_For_Discriminant_Value
: declare
3690 UI_Discrim_Value
: constant Uint
:= Expr_Value
(Discrim_Value
);
3693 Find_Discrete_Value
: while Present
(Variant
) loop
3694 Discrete_Choice
:= First
(Discrete_Choices
(Variant
));
3695 while Present
(Discrete_Choice
) loop
3697 exit Find_Discrete_Value
when
3698 Nkind
(Discrete_Choice
) = N_Others_Choice
;
3700 Get_Index_Bounds
(Discrete_Choice
, Low
, High
);
3702 UI_Low
:= Expr_Value
(Low
);
3703 UI_High
:= Expr_Value
(High
);
3705 exit Find_Discrete_Value
when
3706 UI_Low
<= UI_Discrim_Value
3708 UI_High
>= UI_Discrim_Value
;
3710 Next
(Discrete_Choice
);
3713 Next_Non_Pragma
(Variant
);
3714 end loop Find_Discrete_Value
;
3715 end Search_For_Discriminant_Value
;
3717 if No
(Variant
) then
3719 ("value of discriminant & is out of range", Discrim_Value
, Discrim
);
3720 Report_Errors
:= True;
3724 -- If we have found the corresponding choice, recursively add its
3725 -- components to the Into list.
3727 Gather_Components
(Empty
,
3728 Component_List
(Variant
), Governed_By
, Into
, Report_Errors
);
3729 end Gather_Components
;
3731 ------------------------
3732 -- Get_Actual_Subtype --
3733 ------------------------
3735 function Get_Actual_Subtype
(N
: Node_Id
) return Entity_Id
is
3736 Typ
: constant Entity_Id
:= Etype
(N
);
3737 Utyp
: Entity_Id
:= Underlying_Type
(Typ
);
3746 -- If what we have is an identifier that references a subprogram
3747 -- formal, or a variable or constant object, then we get the actual
3748 -- subtype from the referenced entity if one has been built.
3750 if Nkind
(N
) = N_Identifier
3752 (Is_Formal
(Entity
(N
))
3753 or else Ekind
(Entity
(N
)) = E_Constant
3754 or else Ekind
(Entity
(N
)) = E_Variable
)
3755 and then Present
(Actual_Subtype
(Entity
(N
)))
3757 return Actual_Subtype
(Entity
(N
));
3759 -- Actual subtype of unchecked union is always itself. We never need
3760 -- the "real" actual subtype. If we did, we couldn't get it anyway
3761 -- because the discriminant is not available. The restrictions on
3762 -- Unchecked_Union are designed to make sure that this is OK.
3764 elsif Is_Unchecked_Union
(Base_Type
(Utyp
)) then
3767 -- Here for the unconstrained case, we must find actual subtype
3768 -- No actual subtype is available, so we must build it on the fly.
3770 -- Checking the type, not the underlying type, for constrainedness
3771 -- seems to be necessary. Maybe all the tests should be on the type???
3773 elsif (not Is_Constrained
(Typ
))
3774 and then (Is_Array_Type
(Utyp
)
3775 or else (Is_Record_Type
(Utyp
)
3776 and then Has_Discriminants
(Utyp
)))
3777 and then not Has_Unknown_Discriminants
(Utyp
)
3778 and then not (Ekind
(Utyp
) = E_String_Literal_Subtype
)
3780 -- Nothing to do if in spec expression (why not???)
3782 if In_Spec_Expression
then
3785 elsif Is_Private_Type
(Typ
)
3786 and then not Has_Discriminants
(Typ
)
3788 -- If the type has no discriminants, there is no subtype to
3789 -- build, even if the underlying type is discriminated.
3793 -- Else build the actual subtype
3796 Decl
:= Build_Actual_Subtype
(Typ
, N
);
3797 Atyp
:= Defining_Identifier
(Decl
);
3799 -- If Build_Actual_Subtype generated a new declaration then use it
3803 -- The actual subtype is an Itype, so analyze the declaration,
3804 -- but do not attach it to the tree, to get the type defined.
3806 Set_Parent
(Decl
, N
);
3807 Set_Is_Itype
(Atyp
);
3808 Analyze
(Decl
, Suppress
=> All_Checks
);
3809 Set_Associated_Node_For_Itype
(Atyp
, N
);
3810 Set_Has_Delayed_Freeze
(Atyp
, False);
3812 -- We need to freeze the actual subtype immediately. This is
3813 -- needed, because otherwise this Itype will not get frozen
3814 -- at all, and it is always safe to freeze on creation because
3815 -- any associated types must be frozen at this point.
3817 Freeze_Itype
(Atyp
, N
);
3820 -- Otherwise we did not build a declaration, so return original
3827 -- For all remaining cases, the actual subtype is the same as
3828 -- the nominal type.
3833 end Get_Actual_Subtype
;
3835 -------------------------------------
3836 -- Get_Actual_Subtype_If_Available --
3837 -------------------------------------
3839 function Get_Actual_Subtype_If_Available
(N
: Node_Id
) return Entity_Id
is
3840 Typ
: constant Entity_Id
:= Etype
(N
);
3843 -- If what we have is an identifier that references a subprogram
3844 -- formal, or a variable or constant object, then we get the actual
3845 -- subtype from the referenced entity if one has been built.
3847 if Nkind
(N
) = N_Identifier
3849 (Is_Formal
(Entity
(N
))
3850 or else Ekind
(Entity
(N
)) = E_Constant
3851 or else Ekind
(Entity
(N
)) = E_Variable
)
3852 and then Present
(Actual_Subtype
(Entity
(N
)))
3854 return Actual_Subtype
(Entity
(N
));
3856 -- Otherwise the Etype of N is returned unchanged
3861 end Get_Actual_Subtype_If_Available
;
3863 -------------------------------
3864 -- Get_Default_External_Name --
3865 -------------------------------
3867 function Get_Default_External_Name
(E
: Node_Or_Entity_Id
) return Node_Id
is
3869 Get_Decoded_Name_String
(Chars
(E
));
3871 if Opt
.External_Name_Imp_Casing
= Uppercase
then
3872 Set_Casing
(All_Upper_Case
);
3874 Set_Casing
(All_Lower_Case
);
3878 Make_String_Literal
(Sloc
(E
),
3879 Strval
=> String_From_Name_Buffer
);
3880 end Get_Default_External_Name
;
3882 ---------------------------
3883 -- Get_Enum_Lit_From_Pos --
3884 ---------------------------
3886 function Get_Enum_Lit_From_Pos
3889 Loc
: Source_Ptr
) return Node_Id
3894 -- In the case where the literal is of type Character, Wide_Character
3895 -- or Wide_Wide_Character or of a type derived from them, there needs
3896 -- to be some special handling since there is no explicit chain of
3897 -- literals to search. Instead, an N_Character_Literal node is created
3898 -- with the appropriate Char_Code and Chars fields.
3900 if Is_Standard_Character_Type
(T
) then
3901 Set_Character_Literal_Name
(UI_To_CC
(Pos
));
3903 Make_Character_Literal
(Loc
,
3905 Char_Literal_Value
=> Pos
);
3907 -- For all other cases, we have a complete table of literals, and
3908 -- we simply iterate through the chain of literal until the one
3909 -- with the desired position value is found.
3913 Lit
:= First_Literal
(Base_Type
(T
));
3914 for J
in 1 .. UI_To_Int
(Pos
) loop
3918 return New_Occurrence_Of
(Lit
, Loc
);
3920 end Get_Enum_Lit_From_Pos
;
3922 ------------------------
3923 -- Get_Generic_Entity --
3924 ------------------------
3926 function Get_Generic_Entity
(N
: Node_Id
) return Entity_Id
is
3927 Ent
: constant Entity_Id
:= Entity
(Name
(N
));
3929 if Present
(Renamed_Object
(Ent
)) then
3930 return Renamed_Object
(Ent
);
3934 end Get_Generic_Entity
;
3936 ----------------------
3937 -- Get_Index_Bounds --
3938 ----------------------
3940 procedure Get_Index_Bounds
(N
: Node_Id
; L
, H
: out Node_Id
) is
3941 Kind
: constant Node_Kind
:= Nkind
(N
);
3945 if Kind
= N_Range
then
3947 H
:= High_Bound
(N
);
3949 elsif Kind
= N_Subtype_Indication
then
3950 R
:= Range_Expression
(Constraint
(N
));
3958 L
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
3959 H
:= High_Bound
(Range_Expression
(Constraint
(N
)));
3962 elsif Is_Entity_Name
(N
) and then Is_Type
(Entity
(N
)) then
3963 if Error_Posted
(Scalar_Range
(Entity
(N
))) then
3967 elsif Nkind
(Scalar_Range
(Entity
(N
))) = N_Subtype_Indication
then
3968 Get_Index_Bounds
(Scalar_Range
(Entity
(N
)), L
, H
);
3971 L
:= Low_Bound
(Scalar_Range
(Entity
(N
)));
3972 H
:= High_Bound
(Scalar_Range
(Entity
(N
)));
3976 -- N is an expression, indicating a range with one value
3981 end Get_Index_Bounds
;
3983 ----------------------------------
3984 -- Get_Library_Unit_Name_string --
3985 ----------------------------------
3987 procedure Get_Library_Unit_Name_String
(Decl_Node
: Node_Id
) is
3988 Unit_Name_Id
: constant Unit_Name_Type
:= Get_Unit_Name
(Decl_Node
);
3991 Get_Unit_Name_String
(Unit_Name_Id
);
3993 -- Remove seven last character (" (spec)" or " (body)")
3995 Name_Len
:= Name_Len
- 7;
3996 pragma Assert
(Name_Buffer
(Name_Len
+ 1) = ' ');
3997 end Get_Library_Unit_Name_String
;
3999 ------------------------
4000 -- Get_Name_Entity_Id --
4001 ------------------------
4003 function Get_Name_Entity_Id
(Id
: Name_Id
) return Entity_Id
is
4005 return Entity_Id
(Get_Name_Table_Info
(Id
));
4006 end Get_Name_Entity_Id
;
4012 function Get_Pragma_Id
(N
: Node_Id
) return Pragma_Id
is
4014 return Get_Pragma_Id
(Pragma_Name
(N
));
4017 ---------------------------
4018 -- Get_Referenced_Object --
4019 ---------------------------
4021 function Get_Referenced_Object
(N
: Node_Id
) return Node_Id
is
4026 while Is_Entity_Name
(R
)
4027 and then Present
(Renamed_Object
(Entity
(R
)))
4029 R
:= Renamed_Object
(Entity
(R
));
4033 end Get_Referenced_Object
;
4035 ------------------------
4036 -- Get_Renamed_Entity --
4037 ------------------------
4039 function Get_Renamed_Entity
(E
: Entity_Id
) return Entity_Id
is
4044 while Present
(Renamed_Entity
(R
)) loop
4045 R
:= Renamed_Entity
(R
);
4049 end Get_Renamed_Entity
;
4051 -------------------------
4052 -- Get_Subprogram_Body --
4053 -------------------------
4055 function Get_Subprogram_Body
(E
: Entity_Id
) return Node_Id
is
4059 Decl
:= Unit_Declaration_Node
(E
);
4061 if Nkind
(Decl
) = N_Subprogram_Body
then
4064 -- The below comment is bad, because it is possible for
4065 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
4067 else -- Nkind (Decl) = N_Subprogram_Declaration
4069 if Present
(Corresponding_Body
(Decl
)) then
4070 return Unit_Declaration_Node
(Corresponding_Body
(Decl
));
4072 -- Imported subprogram case
4078 end Get_Subprogram_Body
;
4080 ---------------------------
4081 -- Get_Subprogram_Entity --
4082 ---------------------------
4084 function Get_Subprogram_Entity
(Nod
: Node_Id
) return Entity_Id
is
4089 if Nkind
(Nod
) = N_Accept_Statement
then
4090 Nam
:= Entry_Direct_Name
(Nod
);
4092 -- For an entry call, the prefix of the call is a selected component.
4093 -- Need additional code for internal calls ???
4095 elsif Nkind
(Nod
) = N_Entry_Call_Statement
then
4096 if Nkind
(Name
(Nod
)) = N_Selected_Component
then
4097 Nam
:= Entity
(Selector_Name
(Name
(Nod
)));
4106 if Nkind
(Nam
) = N_Explicit_Dereference
then
4107 Proc
:= Etype
(Prefix
(Nam
));
4108 elsif Is_Entity_Name
(Nam
) then
4109 Proc
:= Entity
(Nam
);
4114 if Is_Object
(Proc
) then
4115 Proc
:= Etype
(Proc
);
4118 if Ekind
(Proc
) = E_Access_Subprogram_Type
then
4119 Proc
:= Directly_Designated_Type
(Proc
);
4122 if not Is_Subprogram
(Proc
)
4123 and then Ekind
(Proc
) /= E_Subprogram_Type
4129 end Get_Subprogram_Entity
;
4131 -----------------------------
4132 -- Get_Task_Body_Procedure --
4133 -----------------------------
4135 function Get_Task_Body_Procedure
(E
: Entity_Id
) return Node_Id
is
4137 -- Note: A task type may be the completion of a private type with
4138 -- discriminants. When performing elaboration checks on a task
4139 -- declaration, the current view of the type may be the private one,
4140 -- and the procedure that holds the body of the task is held in its
4143 -- This is an odd function, why not have Task_Body_Procedure do
4144 -- the following digging???
4146 return Task_Body_Procedure
(Underlying_Type
(Root_Type
(E
)));
4147 end Get_Task_Body_Procedure
;
4149 -----------------------
4150 -- Has_Access_Values --
4151 -----------------------
4153 function Has_Access_Values
(T
: Entity_Id
) return Boolean is
4154 Typ
: constant Entity_Id
:= Underlying_Type
(T
);
4157 -- Case of a private type which is not completed yet. This can only
4158 -- happen in the case of a generic format type appearing directly, or
4159 -- as a component of the type to which this function is being applied
4160 -- at the top level. Return False in this case, since we certainly do
4161 -- not know that the type contains access types.
4166 elsif Is_Access_Type
(Typ
) then
4169 elsif Is_Array_Type
(Typ
) then
4170 return Has_Access_Values
(Component_Type
(Typ
));
4172 elsif Is_Record_Type
(Typ
) then
4177 -- Loop to Check components
4179 Comp
:= First_Component_Or_Discriminant
(Typ
);
4180 while Present
(Comp
) loop
4182 -- Check for access component, tag field does not count, even
4183 -- though it is implemented internally using an access type.
4185 if Has_Access_Values
(Etype
(Comp
))
4186 and then Chars
(Comp
) /= Name_uTag
4191 Next_Component_Or_Discriminant
(Comp
);
4200 end Has_Access_Values
;
4202 ------------------------------
4203 -- Has_Compatible_Alignment --
4204 ------------------------------
4206 function Has_Compatible_Alignment
4208 Expr
: Node_Id
) return Alignment_Result
4210 function Has_Compatible_Alignment_Internal
4213 Default
: Alignment_Result
) return Alignment_Result
;
4214 -- This is the internal recursive function that actually does the work.
4215 -- There is one additional parameter, which says what the result should
4216 -- be if no alignment information is found, and there is no definite
4217 -- indication of compatible alignments. At the outer level, this is set
4218 -- to Unknown, but for internal recursive calls in the case where types
4219 -- are known to be correct, it is set to Known_Compatible.
4221 ---------------------------------------
4222 -- Has_Compatible_Alignment_Internal --
4223 ---------------------------------------
4225 function Has_Compatible_Alignment_Internal
4228 Default
: Alignment_Result
) return Alignment_Result
4230 Result
: Alignment_Result
:= Known_Compatible
;
4231 -- Holds the current status of the result. Note that once a value of
4232 -- Known_Incompatible is set, it is sticky and does not get changed
4233 -- to Unknown (the value in Result only gets worse as we go along,
4236 Offs
: Uint
:= No_Uint
;
4237 -- Set to a factor of the offset from the base object when Expr is a
4238 -- selected or indexed component, based on Component_Bit_Offset and
4239 -- Component_Size respectively. A negative value is used to represent
4240 -- a value which is not known at compile time.
4242 procedure Check_Prefix
;
4243 -- Checks the prefix recursively in the case where the expression
4244 -- is an indexed or selected component.
4246 procedure Set_Result
(R
: Alignment_Result
);
4247 -- If R represents a worse outcome (unknown instead of known
4248 -- compatible, or known incompatible), then set Result to R.
4254 procedure Check_Prefix
is
4256 -- The subtlety here is that in doing a recursive call to check
4257 -- the prefix, we have to decide what to do in the case where we
4258 -- don't find any specific indication of an alignment problem.
4260 -- At the outer level, we normally set Unknown as the result in
4261 -- this case, since we can only set Known_Compatible if we really
4262 -- know that the alignment value is OK, but for the recursive
4263 -- call, in the case where the types match, and we have not
4264 -- specified a peculiar alignment for the object, we are only
4265 -- concerned about suspicious rep clauses, the default case does
4266 -- not affect us, since the compiler will, in the absence of such
4267 -- rep clauses, ensure that the alignment is correct.
4269 if Default
= Known_Compatible
4271 (Etype
(Obj
) = Etype
(Expr
)
4272 and then (Unknown_Alignment
(Obj
)
4274 Alignment
(Obj
) = Alignment
(Etype
(Obj
))))
4277 (Has_Compatible_Alignment_Internal
4278 (Obj
, Prefix
(Expr
), Known_Compatible
));
4280 -- In all other cases, we need a full check on the prefix
4284 (Has_Compatible_Alignment_Internal
4285 (Obj
, Prefix
(Expr
), Unknown
));
4293 procedure Set_Result
(R
: Alignment_Result
) is
4300 -- Start of processing for Has_Compatible_Alignment_Internal
4303 -- If Expr is a selected component, we must make sure there is no
4304 -- potentially troublesome component clause, and that the record is
4307 if Nkind
(Expr
) = N_Selected_Component
then
4309 -- Packed record always generate unknown alignment
4311 if Is_Packed
(Etype
(Prefix
(Expr
))) then
4312 Set_Result
(Unknown
);
4315 -- Check prefix and component offset
4318 Offs
:= Component_Bit_Offset
(Entity
(Selector_Name
(Expr
)));
4320 -- If Expr is an indexed component, we must make sure there is no
4321 -- potentially troublesome Component_Size clause and that the array
4322 -- is not bit-packed.
4324 elsif Nkind
(Expr
) = N_Indexed_Component
then
4326 Typ
: constant Entity_Id
:= Etype
(Prefix
(Expr
));
4327 Ind
: constant Node_Id
:= First_Index
(Typ
);
4330 -- Bit packed array always generates unknown alignment
4332 if Is_Bit_Packed_Array
(Typ
) then
4333 Set_Result
(Unknown
);
4336 -- Check prefix and component offset
4339 Offs
:= Component_Size
(Typ
);
4341 -- Small optimization: compute the full offset when possible
4344 and then Offs
> Uint_0
4345 and then Present
(Ind
)
4346 and then Nkind
(Ind
) = N_Range
4347 and then Compile_Time_Known_Value
(Low_Bound
(Ind
))
4348 and then Compile_Time_Known_Value
(First
(Expressions
(Expr
)))
4350 Offs
:= Offs
* (Expr_Value
(First
(Expressions
(Expr
)))
4351 - Expr_Value
(Low_Bound
((Ind
))));
4356 -- If we have a null offset, the result is entirely determined by
4357 -- the base object and has already been computed recursively.
4359 if Offs
= Uint_0
then
4362 -- Case where we know the alignment of the object
4364 elsif Known_Alignment
(Obj
) then
4366 ObjA
: constant Uint
:= Alignment
(Obj
);
4367 ExpA
: Uint
:= No_Uint
;
4368 SizA
: Uint
:= No_Uint
;
4371 -- If alignment of Obj is 1, then we are always OK
4374 Set_Result
(Known_Compatible
);
4376 -- Alignment of Obj is greater than 1, so we need to check
4379 -- If we have an offset, see if it is compatible
4381 if Offs
/= No_Uint
and Offs
> Uint_0
then
4382 if Offs
mod (System_Storage_Unit
* ObjA
) /= 0 then
4383 Set_Result
(Known_Incompatible
);
4386 -- See if Expr is an object with known alignment
4388 elsif Is_Entity_Name
(Expr
)
4389 and then Known_Alignment
(Entity
(Expr
))
4391 ExpA
:= Alignment
(Entity
(Expr
));
4393 -- Otherwise, we can use the alignment of the type of
4394 -- Expr given that we already checked for
4395 -- discombobulating rep clauses for the cases of indexed
4396 -- and selected components above.
4398 elsif Known_Alignment
(Etype
(Expr
)) then
4399 ExpA
:= Alignment
(Etype
(Expr
));
4401 -- Otherwise the alignment is unknown
4404 Set_Result
(Default
);
4407 -- If we got an alignment, see if it is acceptable
4409 if ExpA
/= No_Uint
and then ExpA
< ObjA
then
4410 Set_Result
(Known_Incompatible
);
4413 -- If Expr is not a piece of a larger object, see if size
4414 -- is given. If so, check that it is not too small for the
4415 -- required alignment.
4417 if Offs
/= No_Uint
then
4420 -- See if Expr is an object with known size
4422 elsif Is_Entity_Name
(Expr
)
4423 and then Known_Static_Esize
(Entity
(Expr
))
4425 SizA
:= Esize
(Entity
(Expr
));
4427 -- Otherwise, we check the object size of the Expr type
4429 elsif Known_Static_Esize
(Etype
(Expr
)) then
4430 SizA
:= Esize
(Etype
(Expr
));
4433 -- If we got a size, see if it is a multiple of the Obj
4434 -- alignment, if not, then the alignment cannot be
4435 -- acceptable, since the size is always a multiple of the
4438 if SizA
/= No_Uint
then
4439 if SizA
mod (ObjA
* Ttypes
.System_Storage_Unit
) /= 0 then
4440 Set_Result
(Known_Incompatible
);
4446 -- If we do not know required alignment, any non-zero offset is a
4447 -- potential problem (but certainly may be OK, so result is unknown).
4449 elsif Offs
/= No_Uint
then
4450 Set_Result
(Unknown
);
4452 -- If we can't find the result by direct comparison of alignment
4453 -- values, then there is still one case that we can determine known
4454 -- result, and that is when we can determine that the types are the
4455 -- same, and no alignments are specified. Then we known that the
4456 -- alignments are compatible, even if we don't know the alignment
4457 -- value in the front end.
4459 elsif Etype
(Obj
) = Etype
(Expr
) then
4461 -- Types are the same, but we have to check for possible size
4462 -- and alignments on the Expr object that may make the alignment
4463 -- different, even though the types are the same.
4465 if Is_Entity_Name
(Expr
) then
4467 -- First check alignment of the Expr object. Any alignment less
4468 -- than Maximum_Alignment is worrisome since this is the case
4469 -- where we do not know the alignment of Obj.
4471 if Known_Alignment
(Entity
(Expr
))
4473 UI_To_Int
(Alignment
(Entity
(Expr
))) <
4474 Ttypes
.Maximum_Alignment
4476 Set_Result
(Unknown
);
4478 -- Now check size of Expr object. Any size that is not an
4479 -- even multiple of Maximum_Alignment is also worrisome
4480 -- since it may cause the alignment of the object to be less
4481 -- than the alignment of the type.
4483 elsif Known_Static_Esize
(Entity
(Expr
))
4485 (UI_To_Int
(Esize
(Entity
(Expr
))) mod
4486 (Ttypes
.Maximum_Alignment
* Ttypes
.System_Storage_Unit
))
4489 Set_Result
(Unknown
);
4491 -- Otherwise same type is decisive
4494 Set_Result
(Known_Compatible
);
4498 -- Another case to deal with is when there is an explicit size or
4499 -- alignment clause when the types are not the same. If so, then the
4500 -- result is Unknown. We don't need to do this test if the Default is
4501 -- Unknown, since that result will be set in any case.
4503 elsif Default
/= Unknown
4504 and then (Has_Size_Clause
(Etype
(Expr
))
4506 Has_Alignment_Clause
(Etype
(Expr
)))
4508 Set_Result
(Unknown
);
4510 -- If no indication found, set default
4513 Set_Result
(Default
);
4516 -- Return worst result found
4519 end Has_Compatible_Alignment_Internal
;
4521 -- Start of processing for Has_Compatible_Alignment
4524 -- If Obj has no specified alignment, then set alignment from the type
4525 -- alignment. Perhaps we should always do this, but for sure we should
4526 -- do it when there is an address clause since we can do more if the
4527 -- alignment is known.
4529 if Unknown_Alignment
(Obj
) then
4530 Set_Alignment
(Obj
, Alignment
(Etype
(Obj
)));
4533 -- Now do the internal call that does all the work
4535 return Has_Compatible_Alignment_Internal
(Obj
, Expr
, Unknown
);
4536 end Has_Compatible_Alignment
;
4538 ----------------------
4539 -- Has_Declarations --
4540 ----------------------
4542 function Has_Declarations
(N
: Node_Id
) return Boolean is
4544 return Nkind_In
(Nkind
(N
), N_Accept_Statement
,
4546 N_Compilation_Unit_Aux
,
4552 N_Package_Specification
);
4553 end Has_Declarations
;
4555 -------------------------------------------
4556 -- Has_Discriminant_Dependent_Constraint --
4557 -------------------------------------------
4559 function Has_Discriminant_Dependent_Constraint
4560 (Comp
: Entity_Id
) return Boolean
4562 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
4563 Subt_Indic
: constant Node_Id
:=
4564 Subtype_Indication
(Component_Definition
(Comp_Decl
));
4569 if Nkind
(Subt_Indic
) = N_Subtype_Indication
then
4570 Constr
:= Constraint
(Subt_Indic
);
4572 if Nkind
(Constr
) = N_Index_Or_Discriminant_Constraint
then
4573 Assn
:= First
(Constraints
(Constr
));
4574 while Present
(Assn
) loop
4575 case Nkind
(Assn
) is
4576 when N_Subtype_Indication |
4580 if Depends_On_Discriminant
(Assn
) then
4584 when N_Discriminant_Association
=>
4585 if Depends_On_Discriminant
(Expression
(Assn
)) then
4600 end Has_Discriminant_Dependent_Constraint
;
4602 --------------------
4603 -- Has_Infinities --
4604 --------------------
4606 function Has_Infinities
(E
: Entity_Id
) return Boolean is
4609 Is_Floating_Point_Type
(E
)
4610 and then Nkind
(Scalar_Range
(E
)) = N_Range
4611 and then Includes_Infinities
(Scalar_Range
(E
));
4614 --------------------
4615 -- Has_Interfaces --
4616 --------------------
4618 function Has_Interfaces
4620 Use_Full_View
: Boolean := True) return Boolean
4622 Typ
: Entity_Id
:= Base_Type
(T
);
4625 -- Handle concurrent types
4627 if Is_Concurrent_Type
(Typ
) then
4628 Typ
:= Corresponding_Record_Type
(Typ
);
4631 if not Present
(Typ
)
4632 or else not Is_Record_Type
(Typ
)
4633 or else not Is_Tagged_Type
(Typ
)
4638 -- Handle private types
4641 and then Present
(Full_View
(Typ
))
4643 Typ
:= Full_View
(Typ
);
4646 -- Handle concurrent record types
4648 if Is_Concurrent_Record_Type
(Typ
)
4649 and then Is_Non_Empty_List
(Abstract_Interface_List
(Typ
))
4655 if Is_Interface
(Typ
)
4657 (Is_Record_Type
(Typ
)
4658 and then Present
(Interfaces
(Typ
))
4659 and then not Is_Empty_Elmt_List
(Interfaces
(Typ
)))
4664 exit when Etype
(Typ
) = Typ
4666 -- Handle private types
4668 or else (Present
(Full_View
(Etype
(Typ
)))
4669 and then Full_View
(Etype
(Typ
)) = Typ
)
4671 -- Protect the frontend against wrong source with cyclic
4674 or else Etype
(Typ
) = T
;
4676 -- Climb to the ancestor type handling private types
4678 if Present
(Full_View
(Etype
(Typ
))) then
4679 Typ
:= Full_View
(Etype
(Typ
));
4688 ------------------------
4689 -- Has_Null_Exclusion --
4690 ------------------------
4692 function Has_Null_Exclusion
(N
: Node_Id
) return Boolean is
4695 when N_Access_Definition |
4696 N_Access_Function_Definition |
4697 N_Access_Procedure_Definition |
4698 N_Access_To_Object_Definition |
4700 N_Derived_Type_Definition |
4701 N_Function_Specification |
4702 N_Subtype_Declaration
=>
4703 return Null_Exclusion_Present
(N
);
4705 when N_Component_Definition |
4706 N_Formal_Object_Declaration |
4707 N_Object_Renaming_Declaration
=>
4708 if Present
(Subtype_Mark
(N
)) then
4709 return Null_Exclusion_Present
(N
);
4710 else pragma Assert
(Present
(Access_Definition
(N
)));
4711 return Null_Exclusion_Present
(Access_Definition
(N
));
4714 when N_Discriminant_Specification
=>
4715 if Nkind
(Discriminant_Type
(N
)) = N_Access_Definition
then
4716 return Null_Exclusion_Present
(Discriminant_Type
(N
));
4718 return Null_Exclusion_Present
(N
);
4721 when N_Object_Declaration
=>
4722 if Nkind
(Object_Definition
(N
)) = N_Access_Definition
then
4723 return Null_Exclusion_Present
(Object_Definition
(N
));
4725 return Null_Exclusion_Present
(N
);
4728 when N_Parameter_Specification
=>
4729 if Nkind
(Parameter_Type
(N
)) = N_Access_Definition
then
4730 return Null_Exclusion_Present
(Parameter_Type
(N
));
4732 return Null_Exclusion_Present
(N
);
4739 end Has_Null_Exclusion
;
4741 ------------------------
4742 -- Has_Null_Extension --
4743 ------------------------
4745 function Has_Null_Extension
(T
: Entity_Id
) return Boolean is
4746 B
: constant Entity_Id
:= Base_Type
(T
);
4751 if Nkind
(Parent
(B
)) = N_Full_Type_Declaration
4752 and then Present
(Record_Extension_Part
(Type_Definition
(Parent
(B
))))
4754 Ext
:= Record_Extension_Part
(Type_Definition
(Parent
(B
)));
4756 if Present
(Ext
) then
4757 if Null_Present
(Ext
) then
4760 Comps
:= Component_List
(Ext
);
4762 -- The null component list is rewritten during analysis to
4763 -- include the parent component. Any other component indicates
4764 -- that the extension was not originally null.
4766 return Null_Present
(Comps
)
4767 or else No
(Next
(First
(Component_Items
(Comps
))));
4776 end Has_Null_Extension
;
4778 -------------------------------
4779 -- Has_Overriding_Initialize --
4780 -------------------------------
4782 function Has_Overriding_Initialize
(T
: Entity_Id
) return Boolean is
4783 BT
: constant Entity_Id
:= Base_Type
(T
);
4788 if Is_Controlled
(BT
) then
4790 -- For derived types, check immediate ancestor, excluding
4791 -- Controlled itself.
4793 if Is_Derived_Type
(BT
)
4794 and then not In_Predefined_Unit
(Etype
(BT
))
4795 and then Has_Overriding_Initialize
(Etype
(BT
))
4799 elsif Present
(Primitive_Operations
(BT
)) then
4800 P
:= First_Elmt
(Primitive_Operations
(BT
));
4801 while Present
(P
) loop
4802 if Chars
(Node
(P
)) = Name_Initialize
4803 and then Comes_From_Source
(Node
(P
))
4814 elsif Has_Controlled_Component
(BT
) then
4815 Comp
:= First_Component
(BT
);
4816 while Present
(Comp
) loop
4817 if Has_Overriding_Initialize
(Etype
(Comp
)) then
4821 Next_Component
(Comp
);
4829 end Has_Overriding_Initialize
;
4831 --------------------------------------
4832 -- Has_Preelaborable_Initialization --
4833 --------------------------------------
4835 function Has_Preelaborable_Initialization
(E
: Entity_Id
) return Boolean is
4838 procedure Check_Components
(E
: Entity_Id
);
4839 -- Check component/discriminant chain, sets Has_PE False if a component
4840 -- or discriminant does not meet the preelaborable initialization rules.
4842 ----------------------
4843 -- Check_Components --
4844 ----------------------
4846 procedure Check_Components
(E
: Entity_Id
) is
4850 function Is_Preelaborable_Expression
(N
: Node_Id
) return Boolean;
4851 -- Returns True if and only if the expression denoted by N does not
4852 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
4854 ---------------------------------
4855 -- Is_Preelaborable_Expression --
4856 ---------------------------------
4858 function Is_Preelaborable_Expression
(N
: Node_Id
) return Boolean is
4862 Comp_Type
: Entity_Id
;
4863 Is_Array_Aggr
: Boolean;
4866 if Is_Static_Expression
(N
) then
4869 elsif Nkind
(N
) = N_Null
then
4872 -- Attributes are allowed in general, even if their prefix is a
4873 -- formal type. (It seems that certain attributes known not to be
4874 -- static might not be allowed, but there are no rules to prevent
4877 elsif Nkind
(N
) = N_Attribute_Reference
then
4880 -- The name of a discriminant evaluated within its parent type is
4881 -- defined to be preelaborable (10.2.1(8)). Note that we test for
4882 -- names that denote discriminals as well as discriminants to
4883 -- catch references occurring within init procs.
4885 elsif Is_Entity_Name
(N
)
4887 (Ekind
(Entity
(N
)) = E_Discriminant
4889 ((Ekind
(Entity
(N
)) = E_Constant
4890 or else Ekind
(Entity
(N
)) = E_In_Parameter
)
4891 and then Present
(Discriminal_Link
(Entity
(N
)))))
4895 elsif Nkind
(N
) = N_Qualified_Expression
then
4896 return Is_Preelaborable_Expression
(Expression
(N
));
4898 -- For aggregates we have to check that each of the associations
4899 -- is preelaborable.
4901 elsif Nkind
(N
) = N_Aggregate
4902 or else Nkind
(N
) = N_Extension_Aggregate
4904 Is_Array_Aggr
:= Is_Array_Type
(Etype
(N
));
4906 if Is_Array_Aggr
then
4907 Comp_Type
:= Component_Type
(Etype
(N
));
4910 -- Check the ancestor part of extension aggregates, which must
4911 -- be either the name of a type that has preelaborable init or
4912 -- an expression that is preelaborable.
4914 if Nkind
(N
) = N_Extension_Aggregate
then
4916 Anc_Part
: constant Node_Id
:= Ancestor_Part
(N
);
4919 if Is_Entity_Name
(Anc_Part
)
4920 and then Is_Type
(Entity
(Anc_Part
))
4922 if not Has_Preelaborable_Initialization
4928 elsif not Is_Preelaborable_Expression
(Anc_Part
) then
4934 -- Check positional associations
4936 Exp
:= First
(Expressions
(N
));
4937 while Present
(Exp
) loop
4938 if not Is_Preelaborable_Expression
(Exp
) then
4945 -- Check named associations
4947 Assn
:= First
(Component_Associations
(N
));
4948 while Present
(Assn
) loop
4949 Choice
:= First
(Choices
(Assn
));
4950 while Present
(Choice
) loop
4951 if Is_Array_Aggr
then
4952 if Nkind
(Choice
) = N_Others_Choice
then
4955 elsif Nkind
(Choice
) = N_Range
then
4956 if not Is_Static_Range
(Choice
) then
4960 elsif not Is_Static_Expression
(Choice
) then
4965 Comp_Type
:= Etype
(Choice
);
4971 -- If the association has a <> at this point, then we have
4972 -- to check whether the component's type has preelaborable
4973 -- initialization. Note that this only occurs when the
4974 -- association's corresponding component does not have a
4975 -- default expression, the latter case having already been
4976 -- expanded as an expression for the association.
4978 if Box_Present
(Assn
) then
4979 if not Has_Preelaborable_Initialization
(Comp_Type
) then
4983 -- In the expression case we check whether the expression
4984 -- is preelaborable.
4987 not Is_Preelaborable_Expression
(Expression
(Assn
))
4995 -- If we get here then aggregate as a whole is preelaborable
4999 -- All other cases are not preelaborable
5004 end Is_Preelaborable_Expression
;
5006 -- Start of processing for Check_Components
5009 -- Loop through entities of record or protected type
5012 while Present
(Ent
) loop
5014 -- We are interested only in components and discriminants
5016 if Ekind_In
(Ent
, E_Component
, E_Discriminant
) then
5018 -- Get default expression if any. If there is no declaration
5019 -- node, it means we have an internal entity. The parent and
5020 -- tag fields are examples of such entities. For these cases,
5021 -- we just test the type of the entity.
5023 if Present
(Declaration_Node
(Ent
)) then
5024 Exp
:= Expression
(Declaration_Node
(Ent
));
5029 -- A component has PI if it has no default expression and the
5030 -- component type has PI.
5033 if not Has_Preelaborable_Initialization
(Etype
(Ent
)) then
5038 -- Require the default expression to be preelaborable
5040 elsif not Is_Preelaborable_Expression
(Exp
) then
5048 end Check_Components
;
5050 -- Start of processing for Has_Preelaborable_Initialization
5053 -- Immediate return if already marked as known preelaborable init. This
5054 -- covers types for which this function has already been called once
5055 -- and returned True (in which case the result is cached), and also
5056 -- types to which a pragma Preelaborable_Initialization applies.
5058 if Known_To_Have_Preelab_Init
(E
) then
5062 -- If the type is a subtype representing a generic actual type, then
5063 -- test whether its base type has preelaborable initialization since
5064 -- the subtype representing the actual does not inherit this attribute
5065 -- from the actual or formal. (but maybe it should???)
5067 if Is_Generic_Actual_Type
(E
) then
5068 return Has_Preelaborable_Initialization
(Base_Type
(E
));
5071 -- All elementary types have preelaborable initialization
5073 if Is_Elementary_Type
(E
) then
5076 -- Array types have PI if the component type has PI
5078 elsif Is_Array_Type
(E
) then
5079 Has_PE
:= Has_Preelaborable_Initialization
(Component_Type
(E
));
5081 -- A derived type has preelaborable initialization if its parent type
5082 -- has preelaborable initialization and (in the case of a derived record
5083 -- extension) if the non-inherited components all have preelaborable
5084 -- initialization. However, a user-defined controlled type with an
5085 -- overriding Initialize procedure does not have preelaborable
5088 elsif Is_Derived_Type
(E
) then
5090 -- If the derived type is a private extension then it doesn't have
5091 -- preelaborable initialization.
5093 if Ekind
(Base_Type
(E
)) = E_Record_Type_With_Private
then
5097 -- First check whether ancestor type has preelaborable initialization
5099 Has_PE
:= Has_Preelaborable_Initialization
(Etype
(Base_Type
(E
)));
5101 -- If OK, check extension components (if any)
5103 if Has_PE
and then Is_Record_Type
(E
) then
5104 Check_Components
(First_Entity
(E
));
5107 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
5108 -- with a user defined Initialize procedure does not have PI.
5111 and then Is_Controlled
(E
)
5112 and then Has_Overriding_Initialize
(E
)
5117 -- Private types not derived from a type having preelaborable init and
5118 -- that are not marked with pragma Preelaborable_Initialization do not
5119 -- have preelaborable initialization.
5121 elsif Is_Private_Type
(E
) then
5124 -- Record type has PI if it is non private and all components have PI
5126 elsif Is_Record_Type
(E
) then
5128 Check_Components
(First_Entity
(E
));
5130 -- Protected types must not have entries, and components must meet
5131 -- same set of rules as for record components.
5133 elsif Is_Protected_Type
(E
) then
5134 if Has_Entries
(E
) then
5138 Check_Components
(First_Entity
(E
));
5139 Check_Components
(First_Private_Entity
(E
));
5142 -- Type System.Address always has preelaborable initialization
5144 elsif Is_RTE
(E
, RE_Address
) then
5147 -- In all other cases, type does not have preelaborable initialization
5153 -- If type has preelaborable initialization, cache result
5156 Set_Known_To_Have_Preelab_Init
(E
);
5160 end Has_Preelaborable_Initialization
;
5162 ---------------------------
5163 -- Has_Private_Component --
5164 ---------------------------
5166 function Has_Private_Component
(Type_Id
: Entity_Id
) return Boolean is
5167 Btype
: Entity_Id
:= Base_Type
(Type_Id
);
5168 Component
: Entity_Id
;
5171 if Error_Posted
(Type_Id
)
5172 or else Error_Posted
(Btype
)
5177 if Is_Class_Wide_Type
(Btype
) then
5178 Btype
:= Root_Type
(Btype
);
5181 if Is_Private_Type
(Btype
) then
5183 UT
: constant Entity_Id
:= Underlying_Type
(Btype
);
5186 if No
(Full_View
(Btype
)) then
5187 return not Is_Generic_Type
(Btype
)
5188 and then not Is_Generic_Type
(Root_Type
(Btype
));
5190 return not Is_Generic_Type
(Root_Type
(Full_View
(Btype
)));
5193 return not Is_Frozen
(UT
) and then Has_Private_Component
(UT
);
5197 elsif Is_Array_Type
(Btype
) then
5198 return Has_Private_Component
(Component_Type
(Btype
));
5200 elsif Is_Record_Type
(Btype
) then
5201 Component
:= First_Component
(Btype
);
5202 while Present
(Component
) loop
5203 if Has_Private_Component
(Etype
(Component
)) then
5207 Next_Component
(Component
);
5212 elsif Is_Protected_Type
(Btype
)
5213 and then Present
(Corresponding_Record_Type
(Btype
))
5215 return Has_Private_Component
(Corresponding_Record_Type
(Btype
));
5220 end Has_Private_Component
;
5226 function Has_Stream
(T
: Entity_Id
) return Boolean is
5233 elsif Is_RTE
(Root_Type
(T
), RE_Root_Stream_Type
) then
5236 elsif Is_Array_Type
(T
) then
5237 return Has_Stream
(Component_Type
(T
));
5239 elsif Is_Record_Type
(T
) then
5240 E
:= First_Component
(T
);
5241 while Present
(E
) loop
5242 if Has_Stream
(Etype
(E
)) then
5251 elsif Is_Private_Type
(T
) then
5252 return Has_Stream
(Underlying_Type
(T
));
5263 function Has_Suffix
(E
: Entity_Id
; Suffix
: Character) return Boolean is
5265 Get_Name_String
(Chars
(E
));
5266 return Name_Buffer
(Name_Len
) = Suffix
;
5269 --------------------------
5270 -- Has_Tagged_Component --
5271 --------------------------
5273 function Has_Tagged_Component
(Typ
: Entity_Id
) return Boolean is
5277 if Is_Private_Type
(Typ
)
5278 and then Present
(Underlying_Type
(Typ
))
5280 return Has_Tagged_Component
(Underlying_Type
(Typ
));
5282 elsif Is_Array_Type
(Typ
) then
5283 return Has_Tagged_Component
(Component_Type
(Typ
));
5285 elsif Is_Tagged_Type
(Typ
) then
5288 elsif Is_Record_Type
(Typ
) then
5289 Comp
:= First_Component
(Typ
);
5290 while Present
(Comp
) loop
5291 if Has_Tagged_Component
(Etype
(Comp
)) then
5295 Next_Component
(Comp
);
5303 end Has_Tagged_Component
;
5305 --------------------------
5306 -- Implements_Interface --
5307 --------------------------
5309 function Implements_Interface
5310 (Typ_Ent
: Entity_Id
;
5311 Iface_Ent
: Entity_Id
;
5312 Exclude_Parents
: Boolean := False) return Boolean
5314 Ifaces_List
: Elist_Id
;
5316 Iface
: Entity_Id
:= Base_Type
(Iface_Ent
);
5317 Typ
: Entity_Id
:= Base_Type
(Typ_Ent
);
5320 if Is_Class_Wide_Type
(Typ
) then
5321 Typ
:= Root_Type
(Typ
);
5324 if not Has_Interfaces
(Typ
) then
5328 if Is_Class_Wide_Type
(Iface
) then
5329 Iface
:= Root_Type
(Iface
);
5332 Collect_Interfaces
(Typ
, Ifaces_List
);
5334 Elmt
:= First_Elmt
(Ifaces_List
);
5335 while Present
(Elmt
) loop
5336 if Is_Ancestor
(Node
(Elmt
), Typ
)
5337 and then Exclude_Parents
5341 elsif Node
(Elmt
) = Iface
then
5349 end Implements_Interface
;
5355 function In_Instance
return Boolean is
5356 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
5362 and then S
/= Standard_Standard
5364 if (Ekind
(S
) = E_Function
5365 or else Ekind
(S
) = E_Package
5366 or else Ekind
(S
) = E_Procedure
)
5367 and then Is_Generic_Instance
(S
)
5369 -- A child instance is always compiled in the context of a parent
5370 -- instance. Nevertheless, the actuals are not analyzed in an
5371 -- instance context. We detect this case by examining the current
5372 -- compilation unit, which must be a child instance, and checking
5373 -- that it is not currently on the scope stack.
5375 if Is_Child_Unit
(Curr_Unit
)
5377 Nkind
(Unit
(Cunit
(Current_Sem_Unit
)))
5378 = N_Package_Instantiation
5379 and then not In_Open_Scopes
(Curr_Unit
)
5393 ----------------------
5394 -- In_Instance_Body --
5395 ----------------------
5397 function In_Instance_Body
return Boolean is
5403 and then S
/= Standard_Standard
5405 if (Ekind
(S
) = E_Function
5406 or else Ekind
(S
) = E_Procedure
)
5407 and then Is_Generic_Instance
(S
)
5411 elsif Ekind
(S
) = E_Package
5412 and then In_Package_Body
(S
)
5413 and then Is_Generic_Instance
(S
)
5422 end In_Instance_Body
;
5424 -----------------------------
5425 -- In_Instance_Not_Visible --
5426 -----------------------------
5428 function In_Instance_Not_Visible
return Boolean is
5434 and then S
/= Standard_Standard
5436 if (Ekind
(S
) = E_Function
5437 or else Ekind
(S
) = E_Procedure
)
5438 and then Is_Generic_Instance
(S
)
5442 elsif Ekind
(S
) = E_Package
5443 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
5444 and then Is_Generic_Instance
(S
)
5453 end In_Instance_Not_Visible
;
5455 ------------------------------
5456 -- In_Instance_Visible_Part --
5457 ------------------------------
5459 function In_Instance_Visible_Part
return Boolean is
5465 and then S
/= Standard_Standard
5467 if Ekind
(S
) = E_Package
5468 and then Is_Generic_Instance
(S
)
5469 and then not In_Package_Body
(S
)
5470 and then not In_Private_Part
(S
)
5479 end In_Instance_Visible_Part
;
5481 ---------------------
5482 -- In_Package_Body --
5483 ---------------------
5485 function In_Package_Body
return Boolean is
5491 and then S
/= Standard_Standard
5493 if Ekind
(S
) = E_Package
5494 and then In_Package_Body
(S
)
5503 end In_Package_Body
;
5505 --------------------------------
5506 -- In_Parameter_Specification --
5507 --------------------------------
5509 function In_Parameter_Specification
(N
: Node_Id
) return Boolean is
5514 while Present
(PN
) loop
5515 if Nkind
(PN
) = N_Parameter_Specification
then
5523 end In_Parameter_Specification
;
5525 --------------------------------------
5526 -- In_Subprogram_Or_Concurrent_Unit --
5527 --------------------------------------
5529 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
5534 -- Use scope chain to check successively outer scopes
5540 if K
in Subprogram_Kind
5541 or else K
in Concurrent_Kind
5542 or else K
in Generic_Subprogram_Kind
5546 elsif E
= Standard_Standard
then
5552 end In_Subprogram_Or_Concurrent_Unit
;
5554 ---------------------
5555 -- In_Visible_Part --
5556 ---------------------
5558 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
5561 Is_Package_Or_Generic_Package
(Scope_Id
)
5562 and then In_Open_Scopes
(Scope_Id
)
5563 and then not In_Package_Body
(Scope_Id
)
5564 and then not In_Private_Part
(Scope_Id
);
5565 end In_Visible_Part
;
5567 ---------------------------------
5568 -- Insert_Explicit_Dereference --
5569 ---------------------------------
5571 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
5572 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
5573 Ent
: Entity_Id
:= Empty
;
5580 Save_Interps
(N
, New_Prefix
);
5582 Rewrite
(N
, Make_Explicit_Dereference
(Sloc
(N
), Prefix
=> New_Prefix
));
5584 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
5586 if Is_Overloaded
(New_Prefix
) then
5588 -- The dereference is also overloaded, and its interpretations are
5589 -- the designated types of the interpretations of the original node.
5591 Set_Etype
(N
, Any_Type
);
5593 Get_First_Interp
(New_Prefix
, I
, It
);
5594 while Present
(It
.Nam
) loop
5597 if Is_Access_Type
(T
) then
5598 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
5601 Get_Next_Interp
(I
, It
);
5607 -- Prefix is unambiguous: mark the original prefix (which might
5608 -- Come_From_Source) as a reference, since the new (relocated) one
5609 -- won't be taken into account.
5611 if Is_Entity_Name
(New_Prefix
) then
5612 Ent
:= Entity
(New_Prefix
);
5614 -- For a retrieval of a subcomponent of some composite object,
5615 -- retrieve the ultimate entity if there is one.
5617 elsif Nkind
(New_Prefix
) = N_Selected_Component
5618 or else Nkind
(New_Prefix
) = N_Indexed_Component
5620 Pref
:= Prefix
(New_Prefix
);
5621 while Present
(Pref
)
5623 (Nkind
(Pref
) = N_Selected_Component
5624 or else Nkind
(Pref
) = N_Indexed_Component
)
5626 Pref
:= Prefix
(Pref
);
5629 if Present
(Pref
) and then Is_Entity_Name
(Pref
) then
5630 Ent
:= Entity
(Pref
);
5634 if Present
(Ent
) then
5635 Generate_Reference
(Ent
, New_Prefix
);
5638 end Insert_Explicit_Dereference
;
5640 ------------------------------------------
5641 -- Inspect_Deferred_Constant_Completion --
5642 ------------------------------------------
5644 procedure Inspect_Deferred_Constant_Completion
(Decls
: List_Id
) is
5648 Decl
:= First
(Decls
);
5649 while Present
(Decl
) loop
5651 -- Deferred constant signature
5653 if Nkind
(Decl
) = N_Object_Declaration
5654 and then Constant_Present
(Decl
)
5655 and then No
(Expression
(Decl
))
5657 -- No need to check internally generated constants
5659 and then Comes_From_Source
(Decl
)
5661 -- The constant is not completed. A full object declaration
5662 -- or a pragma Import complete a deferred constant.
5664 and then not Has_Completion
(Defining_Identifier
(Decl
))
5667 ("constant declaration requires initialization expression",
5668 Defining_Identifier
(Decl
));
5671 Decl
:= Next
(Decl
);
5673 end Inspect_Deferred_Constant_Completion
;
5679 function Is_AAMP_Float
(E
: Entity_Id
) return Boolean is
5680 pragma Assert
(Is_Type
(E
));
5682 return AAMP_On_Target
5683 and then Is_Floating_Point_Type
(E
)
5684 and then E
= Base_Type
(E
);
5687 -----------------------------
5688 -- Is_Actual_Out_Parameter --
5689 -----------------------------
5691 function Is_Actual_Out_Parameter
(N
: Node_Id
) return Boolean is
5695 Find_Actual
(N
, Formal
, Call
);
5696 return Present
(Formal
)
5697 and then Ekind
(Formal
) = E_Out_Parameter
;
5698 end Is_Actual_Out_Parameter
;
5700 -------------------------
5701 -- Is_Actual_Parameter --
5702 -------------------------
5704 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
5705 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
5709 when N_Parameter_Association
=>
5710 return N
= Explicit_Actual_Parameter
(Parent
(N
));
5712 when N_Function_Call | N_Procedure_Call_Statement
=>
5713 return Is_List_Member
(N
)
5715 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
5720 end Is_Actual_Parameter
;
5722 ---------------------
5723 -- Is_Aliased_View --
5724 ---------------------
5726 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
5730 if Is_Entity_Name
(Obj
) then
5738 or else (Present
(Renamed_Object
(E
))
5739 and then Is_Aliased_View
(Renamed_Object
(E
)))))
5741 or else ((Is_Formal
(E
)
5742 or else Ekind
(E
) = E_Generic_In_Out_Parameter
5743 or else Ekind
(E
) = E_Generic_In_Parameter
)
5744 and then Is_Tagged_Type
(Etype
(E
)))
5746 or else (Is_Concurrent_Type
(E
)
5747 and then In_Open_Scopes
(E
))
5749 -- Current instance of type, either directly or as rewritten
5750 -- reference to the current object.
5752 or else (Is_Entity_Name
(Original_Node
(Obj
))
5753 and then Present
(Entity
(Original_Node
(Obj
)))
5754 and then Is_Type
(Entity
(Original_Node
(Obj
))))
5756 or else (Is_Type
(E
) and then E
= Current_Scope
)
5758 or else (Is_Incomplete_Or_Private_Type
(E
)
5759 and then Full_View
(E
) = Current_Scope
);
5761 elsif Nkind
(Obj
) = N_Selected_Component
then
5762 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
5764 elsif Nkind
(Obj
) = N_Indexed_Component
then
5765 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
5767 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
5769 Has_Aliased_Components
5770 (Designated_Type
(Etype
(Prefix
(Obj
)))));
5772 elsif Nkind
(Obj
) = N_Unchecked_Type_Conversion
5773 or else Nkind
(Obj
) = N_Type_Conversion
5775 return Is_Tagged_Type
(Etype
(Obj
))
5776 and then Is_Aliased_View
(Expression
(Obj
));
5778 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
5779 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
5784 end Is_Aliased_View
;
5786 -------------------------
5787 -- Is_Ancestor_Package --
5788 -------------------------
5790 function Is_Ancestor_Package
5792 E2
: Entity_Id
) return Boolean
5799 and then Par
/= Standard_Standard
5809 end Is_Ancestor_Package
;
5811 ----------------------
5812 -- Is_Atomic_Object --
5813 ----------------------
5815 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
5817 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean;
5818 -- Determines if given object has atomic components
5820 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean;
5821 -- If prefix is an implicit dereference, examine designated type
5823 ----------------------
5824 -- Is_Atomic_Prefix --
5825 ----------------------
5827 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean is
5829 if Is_Access_Type
(Etype
(N
)) then
5831 Has_Atomic_Components
(Designated_Type
(Etype
(N
)));
5833 return Object_Has_Atomic_Components
(N
);
5835 end Is_Atomic_Prefix
;
5837 ----------------------------------
5838 -- Object_Has_Atomic_Components --
5839 ----------------------------------
5841 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean is
5843 if Has_Atomic_Components
(Etype
(N
))
5844 or else Is_Atomic
(Etype
(N
))
5848 elsif Is_Entity_Name
(N
)
5849 and then (Has_Atomic_Components
(Entity
(N
))
5850 or else Is_Atomic
(Entity
(N
)))
5854 elsif Nkind
(N
) = N_Indexed_Component
5855 or else Nkind
(N
) = N_Selected_Component
5857 return Is_Atomic_Prefix
(Prefix
(N
));
5862 end Object_Has_Atomic_Components
;
5864 -- Start of processing for Is_Atomic_Object
5867 -- Predicate is not relevant to subprograms
5869 if Is_Entity_Name
(N
)
5870 and then Is_Overloadable
(Entity
(N
))
5874 elsif Is_Atomic
(Etype
(N
))
5875 or else (Is_Entity_Name
(N
) and then Is_Atomic
(Entity
(N
)))
5879 elsif Nkind
(N
) = N_Indexed_Component
5880 or else Nkind
(N
) = N_Selected_Component
5882 return Is_Atomic_Prefix
(Prefix
(N
));
5887 end Is_Atomic_Object
;
5889 -------------------------
5890 -- Is_Coextension_Root --
5891 -------------------------
5893 function Is_Coextension_Root
(N
: Node_Id
) return Boolean is
5896 Nkind
(N
) = N_Allocator
5897 and then Present
(Coextensions
(N
))
5899 -- Anonymous access discriminants carry a list of all nested
5900 -- controlled coextensions.
5902 and then not Is_Dynamic_Coextension
(N
)
5903 and then not Is_Static_Coextension
(N
);
5904 end Is_Coextension_Root
;
5906 -----------------------------
5907 -- Is_Concurrent_Interface --
5908 -----------------------------
5910 function Is_Concurrent_Interface
(T
: Entity_Id
) return Boolean is
5915 (Is_Protected_Interface
(T
)
5916 or else Is_Synchronized_Interface
(T
)
5917 or else Is_Task_Interface
(T
));
5918 end Is_Concurrent_Interface
;
5920 --------------------------------------
5921 -- Is_Controlling_Limited_Procedure --
5922 --------------------------------------
5924 function Is_Controlling_Limited_Procedure
5925 (Proc_Nam
: Entity_Id
) return Boolean
5927 Param_Typ
: Entity_Id
:= Empty
;
5930 if Ekind
(Proc_Nam
) = E_Procedure
5931 and then Present
(Parameter_Specifications
(Parent
(Proc_Nam
)))
5933 Param_Typ
:= Etype
(Parameter_Type
(First
(
5934 Parameter_Specifications
(Parent
(Proc_Nam
)))));
5936 -- In this case where an Itype was created, the procedure call has been
5939 elsif Present
(Associated_Node_For_Itype
(Proc_Nam
))
5940 and then Present
(Original_Node
(Associated_Node_For_Itype
(Proc_Nam
)))
5942 Present
(Parameter_Associations
5943 (Associated_Node_For_Itype
(Proc_Nam
)))
5946 Etype
(First
(Parameter_Associations
5947 (Associated_Node_For_Itype
(Proc_Nam
))));
5950 if Present
(Param_Typ
) then
5952 Is_Interface
(Param_Typ
)
5953 and then Is_Limited_Record
(Param_Typ
);
5957 end Is_Controlling_Limited_Procedure
;
5959 -----------------------------
5960 -- Is_CPP_Constructor_Call --
5961 -----------------------------
5963 function Is_CPP_Constructor_Call
(N
: Node_Id
) return Boolean is
5965 return Nkind
(N
) = N_Function_Call
5966 and then Is_CPP_Class
(Etype
(Etype
(N
)))
5967 and then Is_Constructor
(Entity
(Name
(N
)))
5968 and then Is_Imported
(Entity
(Name
(N
)));
5969 end Is_CPP_Constructor_Call
;
5975 function Is_Delegate
(T
: Entity_Id
) return Boolean is
5976 Desig_Type
: Entity_Id
;
5979 if VM_Target
/= CLI_Target
then
5983 -- Access-to-subprograms are delegates in CIL
5985 if Ekind
(T
) = E_Access_Subprogram_Type
then
5989 if Ekind
(T
) not in Access_Kind
then
5991 -- A delegate is a managed pointer. If no designated type is defined
5992 -- it means that it's not a delegate.
5997 Desig_Type
:= Etype
(Directly_Designated_Type
(T
));
5999 if not Is_Tagged_Type
(Desig_Type
) then
6003 -- Test if the type is inherited from [mscorlib]System.Delegate
6005 while Etype
(Desig_Type
) /= Desig_Type
loop
6006 if Chars
(Scope
(Desig_Type
)) /= No_Name
6007 and then Is_Imported
(Scope
(Desig_Type
))
6008 and then Get_Name_String
(Chars
(Scope
(Desig_Type
))) = "delegate"
6013 Desig_Type
:= Etype
(Desig_Type
);
6019 ----------------------------------------------
6020 -- Is_Dependent_Component_Of_Mutable_Object --
6021 ----------------------------------------------
6023 function Is_Dependent_Component_Of_Mutable_Object
6024 (Object
: Node_Id
) return Boolean
6027 Prefix_Type
: Entity_Id
;
6028 P_Aliased
: Boolean := False;
6031 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean;
6032 -- Returns True if and only if Comp is declared within a variant part
6034 --------------------------------
6035 -- Is_Declared_Within_Variant --
6036 --------------------------------
6038 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
6039 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
6040 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
6042 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
6043 end Is_Declared_Within_Variant
;
6045 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
6048 if Is_Variable
(Object
) then
6050 if Nkind
(Object
) = N_Selected_Component
then
6051 P
:= Prefix
(Object
);
6052 Prefix_Type
:= Etype
(P
);
6054 if Is_Entity_Name
(P
) then
6056 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
6057 Prefix_Type
:= Base_Type
(Prefix_Type
);
6060 if Is_Aliased
(Entity
(P
)) then
6064 -- A discriminant check on a selected component may be
6065 -- expanded into a dereference when removing side-effects.
6066 -- Recover the original node and its type, which may be
6069 elsif Nkind
(P
) = N_Explicit_Dereference
6070 and then not (Comes_From_Source
(P
))
6072 P
:= Original_Node
(P
);
6073 Prefix_Type
:= Etype
(P
);
6076 -- Check for prefix being an aliased component ???
6081 -- A heap object is constrained by its initial value
6083 -- Ada 2005 (AI-363): Always assume the object could be mutable in
6084 -- the dereferenced case, since the access value might denote an
6085 -- unconstrained aliased object, whereas in Ada 95 the designated
6086 -- object is guaranteed to be constrained. A worst-case assumption
6087 -- has to apply in Ada 2005 because we can't tell at compile time
6088 -- whether the object is "constrained by its initial value"
6089 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
6090 -- semantic rules -- these rules are acknowledged to need fixing).
6092 if Ada_Version
< Ada_05
then
6093 if Is_Access_Type
(Prefix_Type
)
6094 or else Nkind
(P
) = N_Explicit_Dereference
6099 elsif Ada_Version
>= Ada_05
then
6100 if Is_Access_Type
(Prefix_Type
) then
6102 -- If the access type is pool-specific, and there is no
6103 -- constrained partial view of the designated type, then the
6104 -- designated object is known to be constrained.
6106 if Ekind
(Prefix_Type
) = E_Access_Type
6107 and then not Has_Constrained_Partial_View
6108 (Designated_Type
(Prefix_Type
))
6112 -- Otherwise (general access type, or there is a constrained
6113 -- partial view of the designated type), we need to check
6114 -- based on the designated type.
6117 Prefix_Type
:= Designated_Type
(Prefix_Type
);
6123 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
6125 -- As per AI-0017, the renaming is illegal in a generic body,
6126 -- even if the subtype is indefinite.
6128 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
6130 if not Is_Constrained
(Prefix_Type
)
6131 and then (not Is_Indefinite_Subtype
(Prefix_Type
)
6133 (Is_Generic_Type
(Prefix_Type
)
6134 and then Ekind
(Current_Scope
) = E_Generic_Package
6135 and then In_Package_Body
(Current_Scope
)))
6137 and then (Is_Declared_Within_Variant
(Comp
)
6138 or else Has_Discriminant_Dependent_Constraint
(Comp
))
6139 and then (not P_Aliased
or else Ada_Version
>= Ada_05
)
6145 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
6149 elsif Nkind
(Object
) = N_Indexed_Component
6150 or else Nkind
(Object
) = N_Slice
6152 return Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
6154 -- A type conversion that Is_Variable is a view conversion:
6155 -- go back to the denoted object.
6157 elsif Nkind
(Object
) = N_Type_Conversion
then
6159 Is_Dependent_Component_Of_Mutable_Object
(Expression
(Object
));
6164 end Is_Dependent_Component_Of_Mutable_Object
;
6166 ---------------------
6167 -- Is_Dereferenced --
6168 ---------------------
6170 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
6171 P
: constant Node_Id
:= Parent
(N
);
6174 (Nkind
(P
) = N_Selected_Component
6176 Nkind
(P
) = N_Explicit_Dereference
6178 Nkind
(P
) = N_Indexed_Component
6180 Nkind
(P
) = N_Slice
)
6181 and then Prefix
(P
) = N
;
6182 end Is_Dereferenced
;
6184 ----------------------
6185 -- Is_Descendent_Of --
6186 ----------------------
6188 function Is_Descendent_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
6193 pragma Assert
(Nkind
(T1
) in N_Entity
);
6194 pragma Assert
(Nkind
(T2
) in N_Entity
);
6196 T
:= Base_Type
(T1
);
6198 -- Immediate return if the types match
6203 -- Comment needed here ???
6205 elsif Ekind
(T
) = E_Class_Wide_Type
then
6206 return Etype
(T
) = T2
;
6214 -- Done if we found the type we are looking for
6219 -- Done if no more derivations to check
6226 -- Following test catches error cases resulting from prev errors
6228 elsif No
(Etyp
) then
6231 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
6234 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
6238 T
:= Base_Type
(Etyp
);
6241 end Is_Descendent_Of
;
6247 function Is_False
(U
: Uint
) return Boolean is
6252 ---------------------------
6253 -- Is_Fixed_Model_Number --
6254 ---------------------------
6256 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
6257 S
: constant Ureal
:= Small_Value
(T
);
6258 M
: Urealp
.Save_Mark
;
6262 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
6265 end Is_Fixed_Model_Number
;
6267 -------------------------------
6268 -- Is_Fully_Initialized_Type --
6269 -------------------------------
6271 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
6273 if Is_Scalar_Type
(Typ
) then
6276 elsif Is_Access_Type
(Typ
) then
6279 elsif Is_Array_Type
(Typ
) then
6280 if Is_Fully_Initialized_Type
(Component_Type
(Typ
)) then
6284 -- An interesting case, if we have a constrained type one of whose
6285 -- bounds is known to be null, then there are no elements to be
6286 -- initialized, so all the elements are initialized!
6288 if Is_Constrained
(Typ
) then
6291 Indx_Typ
: Entity_Id
;
6295 Indx
:= First_Index
(Typ
);
6296 while Present
(Indx
) loop
6297 if Etype
(Indx
) = Any_Type
then
6300 -- If index is a range, use directly
6302 elsif Nkind
(Indx
) = N_Range
then
6303 Lbd
:= Low_Bound
(Indx
);
6304 Hbd
:= High_Bound
(Indx
);
6307 Indx_Typ
:= Etype
(Indx
);
6309 if Is_Private_Type
(Indx_Typ
) then
6310 Indx_Typ
:= Full_View
(Indx_Typ
);
6313 if No
(Indx_Typ
) or else Etype
(Indx_Typ
) = Any_Type
then
6316 Lbd
:= Type_Low_Bound
(Indx_Typ
);
6317 Hbd
:= Type_High_Bound
(Indx_Typ
);
6321 if Compile_Time_Known_Value
(Lbd
)
6322 and then Compile_Time_Known_Value
(Hbd
)
6324 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
6334 -- If no null indexes, then type is not fully initialized
6340 elsif Is_Record_Type
(Typ
) then
6341 if Has_Discriminants
(Typ
)
6343 Present
(Discriminant_Default_Value
(First_Discriminant
(Typ
)))
6344 and then Is_Fully_Initialized_Variant
(Typ
)
6349 -- Controlled records are considered to be fully initialized if
6350 -- there is a user defined Initialize routine. This may not be
6351 -- entirely correct, but as the spec notes, we are guessing here
6352 -- what is best from the point of view of issuing warnings.
6354 if Is_Controlled
(Typ
) then
6356 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
6359 if Present
(Utyp
) then
6361 Init
: constant Entity_Id
:=
6363 (Underlying_Type
(Typ
), Name_Initialize
));
6367 and then Comes_From_Source
(Init
)
6369 Is_Predefined_File_Name
6370 (File_Name
(Get_Source_File_Index
(Sloc
(Init
))))
6374 elsif Has_Null_Extension
(Typ
)
6376 Is_Fully_Initialized_Type
6377 (Etype
(Base_Type
(Typ
)))
6386 -- Otherwise see if all record components are initialized
6392 Ent
:= First_Entity
(Typ
);
6393 while Present
(Ent
) loop
6394 if Chars
(Ent
) = Name_uController
then
6397 elsif Ekind
(Ent
) = E_Component
6398 and then (No
(Parent
(Ent
))
6399 or else No
(Expression
(Parent
(Ent
))))
6400 and then not Is_Fully_Initialized_Type
(Etype
(Ent
))
6402 -- Special VM case for tag components, which need to be
6403 -- defined in this case, but are never initialized as VMs
6404 -- are using other dispatching mechanisms. Ignore this
6405 -- uninitialized case. Note that this applies both to the
6406 -- uTag entry and the main vtable pointer (CPP_Class case).
6408 and then (Tagged_Type_Expansion
or else not Is_Tag
(Ent
))
6417 -- No uninitialized components, so type is fully initialized.
6418 -- Note that this catches the case of no components as well.
6422 elsif Is_Concurrent_Type
(Typ
) then
6425 elsif Is_Private_Type
(Typ
) then
6427 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
6433 return Is_Fully_Initialized_Type
(U
);
6440 end Is_Fully_Initialized_Type
;
6442 ----------------------------------
6443 -- Is_Fully_Initialized_Variant --
6444 ----------------------------------
6446 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
6447 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6448 Constraints
: constant List_Id
:= New_List
;
6449 Components
: constant Elist_Id
:= New_Elmt_List
;
6450 Comp_Elmt
: Elmt_Id
;
6452 Comp_List
: Node_Id
;
6454 Discr_Val
: Node_Id
;
6456 Report_Errors
: Boolean;
6457 pragma Warnings
(Off
, Report_Errors
);
6460 if Serious_Errors_Detected
> 0 then
6464 if Is_Record_Type
(Typ
)
6465 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
6466 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
6468 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
6470 Discr
:= First_Discriminant
(Typ
);
6471 while Present
(Discr
) loop
6472 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
6473 Discr_Val
:= Expression
(Parent
(Discr
));
6475 if Present
(Discr_Val
)
6476 and then Is_OK_Static_Expression
(Discr_Val
)
6478 Append_To
(Constraints
,
6479 Make_Component_Association
(Loc
,
6480 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
6481 Expression
=> New_Copy
(Discr_Val
)));
6489 Next_Discriminant
(Discr
);
6494 Comp_List
=> Comp_List
,
6495 Governed_By
=> Constraints
,
6497 Report_Errors
=> Report_Errors
);
6499 -- Check that each component present is fully initialized
6501 Comp_Elmt
:= First_Elmt
(Components
);
6502 while Present
(Comp_Elmt
) loop
6503 Comp_Id
:= Node
(Comp_Elmt
);
6505 if Ekind
(Comp_Id
) = E_Component
6506 and then (No
(Parent
(Comp_Id
))
6507 or else No
(Expression
(Parent
(Comp_Id
))))
6508 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
6513 Next_Elmt
(Comp_Elmt
);
6518 elsif Is_Private_Type
(Typ
) then
6520 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
6526 return Is_Fully_Initialized_Variant
(U
);
6532 end Is_Fully_Initialized_Variant
;
6538 -- We seem to have a lot of overlapping functions that do similar things
6539 -- (testing for left hand sides or lvalues???). Anyway, since this one is
6540 -- purely syntactic, it should be in Sem_Aux I would think???
6542 function Is_LHS
(N
: Node_Id
) return Boolean is
6543 P
: constant Node_Id
:= Parent
(N
);
6545 return Nkind
(P
) = N_Assignment_Statement
6546 and then Name
(P
) = N
;
6549 ----------------------------
6550 -- Is_Inherited_Operation --
6551 ----------------------------
6553 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
6554 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
6556 pragma Assert
(Is_Overloadable
(E
));
6557 return Kind
= N_Full_Type_Declaration
6558 or else Kind
= N_Private_Extension_Declaration
6559 or else Kind
= N_Subtype_Declaration
6560 or else (Ekind
(E
) = E_Enumeration_Literal
6561 and then Is_Derived_Type
(Etype
(E
)));
6562 end Is_Inherited_Operation
;
6564 -----------------------------
6565 -- Is_Library_Level_Entity --
6566 -----------------------------
6568 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
6570 -- The following is a small optimization, and it also properly handles
6571 -- discriminals, which in task bodies might appear in expressions before
6572 -- the corresponding procedure has been created, and which therefore do
6573 -- not have an assigned scope.
6575 if Is_Formal
(E
) then
6579 -- Normal test is simply that the enclosing dynamic scope is Standard
6581 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
6582 end Is_Library_Level_Entity
;
6584 ---------------------------------
6585 -- Is_Local_Variable_Reference --
6586 ---------------------------------
6588 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
6590 if not Is_Entity_Name
(Expr
) then
6595 Ent
: constant Entity_Id
:= Entity
(Expr
);
6596 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
6598 if not Ekind_In
(Ent
, E_Variable
, E_In_Out_Parameter
) then
6601 return Present
(Sub
) and then Sub
= Current_Subprogram
;
6605 end Is_Local_Variable_Reference
;
6607 -------------------------
6608 -- Is_Object_Reference --
6609 -------------------------
6611 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
6613 if Is_Entity_Name
(N
) then
6614 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
));
6618 when N_Indexed_Component | N_Slice
=>
6620 Is_Object_Reference
(Prefix
(N
))
6621 or else Is_Access_Type
(Etype
(Prefix
(N
)));
6623 -- In Ada95, a function call is a constant object; a procedure
6626 when N_Function_Call
=>
6627 return Etype
(N
) /= Standard_Void_Type
;
6629 -- A reference to the stream attribute Input is a function call
6631 when N_Attribute_Reference
=>
6632 return Attribute_Name
(N
) = Name_Input
;
6634 when N_Selected_Component
=>
6636 Is_Object_Reference
(Selector_Name
(N
))
6638 (Is_Object_Reference
(Prefix
(N
))
6639 or else Is_Access_Type
(Etype
(Prefix
(N
))));
6641 when N_Explicit_Dereference
=>
6644 -- A view conversion of a tagged object is an object reference
6646 when N_Type_Conversion
=>
6647 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
6648 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
6649 and then Is_Object_Reference
(Expression
(N
));
6651 -- An unchecked type conversion is considered to be an object if
6652 -- the operand is an object (this construction arises only as a
6653 -- result of expansion activities).
6655 when N_Unchecked_Type_Conversion
=>
6662 end Is_Object_Reference
;
6664 -----------------------------------
6665 -- Is_OK_Variable_For_Out_Formal --
6666 -----------------------------------
6668 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
6670 Note_Possible_Modification
(AV
, Sure
=> True);
6672 -- We must reject parenthesized variable names. The check for
6673 -- Comes_From_Source is present because there are currently
6674 -- cases where the compiler violates this rule (e.g. passing
6675 -- a task object to its controlled Initialize routine).
6677 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
6680 -- A variable is always allowed
6682 elsif Is_Variable
(AV
) then
6685 -- Unchecked conversions are allowed only if they come from the
6686 -- generated code, which sometimes uses unchecked conversions for out
6687 -- parameters in cases where code generation is unaffected. We tell
6688 -- source unchecked conversions by seeing if they are rewrites of an
6689 -- original Unchecked_Conversion function call, or of an explicit
6690 -- conversion of a function call.
6692 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
6693 if Nkind
(Original_Node
(AV
)) = N_Function_Call
then
6696 elsif Comes_From_Source
(AV
)
6697 and then Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
6701 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
6702 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
6708 -- Normal type conversions are allowed if argument is a variable
6710 elsif Nkind
(AV
) = N_Type_Conversion
then
6711 if Is_Variable
(Expression
(AV
))
6712 and then Paren_Count
(Expression
(AV
)) = 0
6714 Note_Possible_Modification
(Expression
(AV
), Sure
=> True);
6717 -- We also allow a non-parenthesized expression that raises
6718 -- constraint error if it rewrites what used to be a variable
6720 elsif Raises_Constraint_Error
(Expression
(AV
))
6721 and then Paren_Count
(Expression
(AV
)) = 0
6722 and then Is_Variable
(Original_Node
(Expression
(AV
)))
6726 -- Type conversion of something other than a variable
6732 -- If this node is rewritten, then test the original form, if that is
6733 -- OK, then we consider the rewritten node OK (for example, if the
6734 -- original node is a conversion, then Is_Variable will not be true
6735 -- but we still want to allow the conversion if it converts a variable).
6737 elsif Original_Node
(AV
) /= AV
then
6738 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
6740 -- All other non-variables are rejected
6745 end Is_OK_Variable_For_Out_Formal
;
6747 -----------------------------------
6748 -- Is_Partially_Initialized_Type --
6749 -----------------------------------
6751 function Is_Partially_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
6753 if Is_Scalar_Type
(Typ
) then
6756 elsif Is_Access_Type
(Typ
) then
6759 elsif Is_Array_Type
(Typ
) then
6761 -- If component type is partially initialized, so is array type
6763 if Is_Partially_Initialized_Type
(Component_Type
(Typ
)) then
6766 -- Otherwise we are only partially initialized if we are fully
6767 -- initialized (this is the empty array case, no point in us
6768 -- duplicating that code here).
6771 return Is_Fully_Initialized_Type
(Typ
);
6774 elsif Is_Record_Type
(Typ
) then
6776 -- A discriminated type is always partially initialized
6778 if Has_Discriminants
(Typ
) then
6781 -- A tagged type is always partially initialized
6783 elsif Is_Tagged_Type
(Typ
) then
6786 -- Case of non-discriminated record
6792 Component_Present
: Boolean := False;
6793 -- Set True if at least one component is present. If no
6794 -- components are present, then record type is fully
6795 -- initialized (another odd case, like the null array).
6798 -- Loop through components
6800 Ent
:= First_Entity
(Typ
);
6801 while Present
(Ent
) loop
6802 if Ekind
(Ent
) = E_Component
then
6803 Component_Present
:= True;
6805 -- If a component has an initialization expression then
6806 -- the enclosing record type is partially initialized
6808 if Present
(Parent
(Ent
))
6809 and then Present
(Expression
(Parent
(Ent
)))
6813 -- If a component is of a type which is itself partially
6814 -- initialized, then the enclosing record type is also.
6816 elsif Is_Partially_Initialized_Type
(Etype
(Ent
)) then
6824 -- No initialized components found. If we found any components
6825 -- they were all uninitialized so the result is false.
6827 if Component_Present
then
6830 -- But if we found no components, then all the components are
6831 -- initialized so we consider the type to be initialized.
6839 -- Concurrent types are always fully initialized
6841 elsif Is_Concurrent_Type
(Typ
) then
6844 -- For a private type, go to underlying type. If there is no underlying
6845 -- type then just assume this partially initialized. Not clear if this
6846 -- can happen in a non-error case, but no harm in testing for this.
6848 elsif Is_Private_Type
(Typ
) then
6850 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
6855 return Is_Partially_Initialized_Type
(U
);
6859 -- For any other type (are there any?) assume partially initialized
6864 end Is_Partially_Initialized_Type
;
6866 ------------------------------------
6867 -- Is_Potentially_Persistent_Type --
6868 ------------------------------------
6870 function Is_Potentially_Persistent_Type
(T
: Entity_Id
) return Boolean is
6875 -- For private type, test corresponding full type
6877 if Is_Private_Type
(T
) then
6878 return Is_Potentially_Persistent_Type
(Full_View
(T
));
6880 -- Scalar types are potentially persistent
6882 elsif Is_Scalar_Type
(T
) then
6885 -- Record type is potentially persistent if not tagged and the types of
6886 -- all it components are potentially persistent, and no component has
6887 -- an initialization expression.
6889 elsif Is_Record_Type
(T
)
6890 and then not Is_Tagged_Type
(T
)
6891 and then not Is_Partially_Initialized_Type
(T
)
6893 Comp
:= First_Component
(T
);
6894 while Present
(Comp
) loop
6895 if not Is_Potentially_Persistent_Type
(Etype
(Comp
)) then
6904 -- Array type is potentially persistent if its component type is
6905 -- potentially persistent and if all its constraints are static.
6907 elsif Is_Array_Type
(T
) then
6908 if not Is_Potentially_Persistent_Type
(Component_Type
(T
)) then
6912 Indx
:= First_Index
(T
);
6913 while Present
(Indx
) loop
6914 if not Is_OK_Static_Subtype
(Etype
(Indx
)) then
6923 -- All other types are not potentially persistent
6928 end Is_Potentially_Persistent_Type
;
6930 ---------------------------------
6931 -- Is_Protected_Self_Reference --
6932 ---------------------------------
6934 function Is_Protected_Self_Reference
(N
: Node_Id
) return Boolean is
6936 function In_Access_Definition
(N
: Node_Id
) return Boolean;
6937 -- Returns true if N belongs to an access definition
6939 --------------------------
6940 -- In_Access_Definition --
6941 --------------------------
6943 function In_Access_Definition
(N
: Node_Id
) return Boolean is
6948 while Present
(P
) loop
6949 if Nkind
(P
) = N_Access_Definition
then
6957 end In_Access_Definition
;
6959 -- Start of processing for Is_Protected_Self_Reference
6962 -- Verify that prefix is analyzed and has the proper form. Note that
6963 -- the attributes Elab_Spec, Elab_Body, and UET_Address, which also
6964 -- produce the address of an entity, do not analyze their prefix
6965 -- because they denote entities that are not necessarily visible.
6966 -- Neither of them can apply to a protected type.
6968 return Ada_Version
>= Ada_05
6969 and then Is_Entity_Name
(N
)
6970 and then Present
(Entity
(N
))
6971 and then Is_Protected_Type
(Entity
(N
))
6972 and then In_Open_Scopes
(Entity
(N
))
6973 and then not In_Access_Definition
(N
);
6974 end Is_Protected_Self_Reference
;
6976 -----------------------------
6977 -- Is_RCI_Pkg_Spec_Or_Body --
6978 -----------------------------
6980 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
6982 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
6983 -- Return True if the unit of Cunit is an RCI package declaration
6985 ---------------------------
6986 -- Is_RCI_Pkg_Decl_Cunit --
6987 ---------------------------
6989 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
6990 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
6993 if Nkind
(The_Unit
) /= N_Package_Declaration
then
6997 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
6998 end Is_RCI_Pkg_Decl_Cunit
;
7000 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
7003 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
7005 (Nkind
(Unit
(Cunit
)) = N_Package_Body
7006 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
7007 end Is_RCI_Pkg_Spec_Or_Body
;
7009 -----------------------------------------
7010 -- Is_Remote_Access_To_Class_Wide_Type --
7011 -----------------------------------------
7013 function Is_Remote_Access_To_Class_Wide_Type
7014 (E
: Entity_Id
) return Boolean
7017 -- A remote access to class-wide type is a general access to object type
7018 -- declared in the visible part of a Remote_Types or Remote_Call_
7021 return Ekind
(E
) = E_General_Access_Type
7022 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
7023 end Is_Remote_Access_To_Class_Wide_Type
;
7025 -----------------------------------------
7026 -- Is_Remote_Access_To_Subprogram_Type --
7027 -----------------------------------------
7029 function Is_Remote_Access_To_Subprogram_Type
7030 (E
: Entity_Id
) return Boolean
7033 return (Ekind
(E
) = E_Access_Subprogram_Type
7034 or else (Ekind
(E
) = E_Record_Type
7035 and then Present
(Corresponding_Remote_Type
(E
))))
7036 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
7037 end Is_Remote_Access_To_Subprogram_Type
;
7039 --------------------
7040 -- Is_Remote_Call --
7041 --------------------
7043 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
7045 if Nkind
(N
) /= N_Procedure_Call_Statement
7046 and then Nkind
(N
) /= N_Function_Call
7048 -- An entry call cannot be remote
7052 elsif Nkind
(Name
(N
)) in N_Has_Entity
7053 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
7055 -- A subprogram declared in the spec of a RCI package is remote
7059 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
7060 and then Is_Remote_Access_To_Subprogram_Type
7061 (Etype
(Prefix
(Name
(N
))))
7063 -- The dereference of a RAS is a remote call
7067 elsif Present
(Controlling_Argument
(N
))
7068 and then Is_Remote_Access_To_Class_Wide_Type
7069 (Etype
(Controlling_Argument
(N
)))
7071 -- Any primitive operation call with a controlling argument of
7072 -- a RACW type is a remote call.
7077 -- All other calls are local calls
7082 ----------------------
7083 -- Is_Renamed_Entry --
7084 ----------------------
7086 function Is_Renamed_Entry
(Proc_Nam
: Entity_Id
) return Boolean is
7087 Orig_Node
: Node_Id
:= Empty
;
7088 Subp_Decl
: Node_Id
:= Parent
(Parent
(Proc_Nam
));
7090 function Is_Entry
(Nam
: Node_Id
) return Boolean;
7091 -- Determine whether Nam is an entry. Traverse selectors if there are
7092 -- nested selected components.
7098 function Is_Entry
(Nam
: Node_Id
) return Boolean is
7100 if Nkind
(Nam
) = N_Selected_Component
then
7101 return Is_Entry
(Selector_Name
(Nam
));
7104 return Ekind
(Entity
(Nam
)) = E_Entry
;
7107 -- Start of processing for Is_Renamed_Entry
7110 if Present
(Alias
(Proc_Nam
)) then
7111 Subp_Decl
:= Parent
(Parent
(Alias
(Proc_Nam
)));
7114 -- Look for a rewritten subprogram renaming declaration
7116 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
7117 and then Present
(Original_Node
(Subp_Decl
))
7119 Orig_Node
:= Original_Node
(Subp_Decl
);
7122 -- The rewritten subprogram is actually an entry
7124 if Present
(Orig_Node
)
7125 and then Nkind
(Orig_Node
) = N_Subprogram_Renaming_Declaration
7126 and then Is_Entry
(Name
(Orig_Node
))
7132 end Is_Renamed_Entry
;
7134 ----------------------
7135 -- Is_Selector_Name --
7136 ----------------------
7138 function Is_Selector_Name
(N
: Node_Id
) return Boolean is
7140 if not Is_List_Member
(N
) then
7142 P
: constant Node_Id
:= Parent
(N
);
7143 K
: constant Node_Kind
:= Nkind
(P
);
7146 (K
= N_Expanded_Name
or else
7147 K
= N_Generic_Association
or else
7148 K
= N_Parameter_Association
or else
7149 K
= N_Selected_Component
)
7150 and then Selector_Name
(P
) = N
;
7155 L
: constant List_Id
:= List_Containing
(N
);
7156 P
: constant Node_Id
:= Parent
(L
);
7158 return (Nkind
(P
) = N_Discriminant_Association
7159 and then Selector_Names
(P
) = L
)
7161 (Nkind
(P
) = N_Component_Association
7162 and then Choices
(P
) = L
);
7165 end Is_Selector_Name
;
7171 function Is_Statement
(N
: Node_Id
) return Boolean is
7174 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
7175 or else Nkind
(N
) = N_Procedure_Call_Statement
;
7178 ---------------------------------
7179 -- Is_Synchronized_Tagged_Type --
7180 ---------------------------------
7182 function Is_Synchronized_Tagged_Type
(E
: Entity_Id
) return Boolean is
7183 Kind
: constant Entity_Kind
:= Ekind
(Base_Type
(E
));
7186 -- A task or protected type derived from an interface is a tagged type.
7187 -- Such a tagged type is called a synchronized tagged type, as are
7188 -- synchronized interfaces and private extensions whose declaration
7189 -- includes the reserved word synchronized.
7191 return (Is_Tagged_Type
(E
)
7192 and then (Kind
= E_Task_Type
7193 or else Kind
= E_Protected_Type
))
7196 and then Is_Synchronized_Interface
(E
))
7198 (Ekind
(E
) = E_Record_Type_With_Private
7199 and then (Synchronized_Present
(Parent
(E
))
7200 or else Is_Synchronized_Interface
(Etype
(E
))));
7201 end Is_Synchronized_Tagged_Type
;
7207 function Is_Transfer
(N
: Node_Id
) return Boolean is
7208 Kind
: constant Node_Kind
:= Nkind
(N
);
7211 if Kind
= N_Simple_Return_Statement
7213 Kind
= N_Extended_Return_Statement
7215 Kind
= N_Goto_Statement
7217 Kind
= N_Raise_Statement
7219 Kind
= N_Requeue_Statement
7223 elsif (Kind
= N_Exit_Statement
or else Kind
in N_Raise_xxx_Error
)
7224 and then No
(Condition
(N
))
7228 elsif Kind
= N_Procedure_Call_Statement
7229 and then Is_Entity_Name
(Name
(N
))
7230 and then Present
(Entity
(Name
(N
)))
7231 and then No_Return
(Entity
(Name
(N
)))
7235 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
7247 function Is_True
(U
: Uint
) return Boolean is
7252 -------------------------------
7253 -- Is_Universal_Numeric_Type --
7254 -------------------------------
7256 function Is_Universal_Numeric_Type
(T
: Entity_Id
) return Boolean is
7258 return T
= Universal_Integer
or else T
= Universal_Real
;
7259 end Is_Universal_Numeric_Type
;
7265 function Is_Value_Type
(T
: Entity_Id
) return Boolean is
7267 return VM_Target
= CLI_Target
7268 and then Nkind
(T
) in N_Has_Chars
7269 and then Chars
(T
) /= No_Name
7270 and then Get_Name_String
(Chars
(T
)) = "valuetype";
7273 ---------------------
7274 -- Is_VMS_Operator --
7275 ---------------------
7277 function Is_VMS_Operator
(Op
: Entity_Id
) return Boolean is
7279 -- The VMS operators are declared in a child of System that is loaded
7280 -- through pragma Extend_System. In some rare cases a program is run
7281 -- with this extension but without indicating that the target is VMS.
7283 return Ekind
(Op
) = E_Function
7284 and then Is_Intrinsic_Subprogram
(Op
)
7286 ((Present_System_Aux
7287 and then Scope
(Op
) = System_Aux_Id
)
7290 and then Scope
(Scope
(Op
)) = RTU_Entity
(System
)));
7291 end Is_VMS_Operator
;
7297 function Is_Variable
(N
: Node_Id
) return Boolean is
7299 Orig_Node
: constant Node_Id
:= Original_Node
(N
);
7300 -- We do the test on the original node, since this is basically a test
7301 -- of syntactic categories, so it must not be disturbed by whatever
7302 -- rewriting might have occurred. For example, an aggregate, which is
7303 -- certainly NOT a variable, could be turned into a variable by
7306 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
7307 -- Within a protected function, the private components of the enclosing
7308 -- protected type are constants. A function nested within a (protected)
7309 -- procedure is not itself protected.
7311 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
7312 -- Prefixes can involve implicit dereferences, in which case we must
7313 -- test for the case of a reference of a constant access type, which can
7314 -- can never be a variable.
7316 ---------------------------
7317 -- In_Protected_Function --
7318 ---------------------------
7320 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
7321 Prot
: constant Entity_Id
:= Scope
(E
);
7325 if not Is_Protected_Type
(Prot
) then
7329 while Present
(S
) and then S
/= Prot
loop
7330 if Ekind
(S
) = E_Function
and then Scope
(S
) = Prot
then
7339 end In_Protected_Function
;
7341 ------------------------
7342 -- Is_Variable_Prefix --
7343 ------------------------
7345 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
7347 if Is_Access_Type
(Etype
(P
)) then
7348 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
7350 -- For the case of an indexed component whose prefix has a packed
7351 -- array type, the prefix has been rewritten into a type conversion.
7352 -- Determine variable-ness from the converted expression.
7354 elsif Nkind
(P
) = N_Type_Conversion
7355 and then not Comes_From_Source
(P
)
7356 and then Is_Array_Type
(Etype
(P
))
7357 and then Is_Packed
(Etype
(P
))
7359 return Is_Variable
(Expression
(P
));
7362 return Is_Variable
(P
);
7364 end Is_Variable_Prefix
;
7366 -- Start of processing for Is_Variable
7369 -- Definitely OK if Assignment_OK is set. Since this is something that
7370 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
7372 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
7375 -- Normally we go to the original node, but there is one exception where
7376 -- we use the rewritten node, namely when it is an explicit dereference.
7377 -- The generated code may rewrite a prefix which is an access type with
7378 -- an explicit dereference. The dereference is a variable, even though
7379 -- the original node may not be (since it could be a constant of the
7382 -- In Ada 2005 we have a further case to consider: the prefix may be a
7383 -- function call given in prefix notation. The original node appears to
7384 -- be a selected component, but we need to examine the call.
7386 elsif Nkind
(N
) = N_Explicit_Dereference
7387 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
7388 and then Present
(Etype
(Orig_Node
))
7389 and then Is_Access_Type
(Etype
(Orig_Node
))
7391 -- Note that if the prefix is an explicit dereference that does not
7392 -- come from source, we must check for a rewritten function call in
7393 -- prefixed notation before other forms of rewriting, to prevent a
7397 (Nkind
(Orig_Node
) = N_Function_Call
7398 and then not Is_Access_Constant
(Etype
(Prefix
(N
))))
7400 Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
7402 -- A function call is never a variable
7404 elsif Nkind
(N
) = N_Function_Call
then
7407 -- All remaining checks use the original node
7409 elsif Is_Entity_Name
(Orig_Node
)
7410 and then Present
(Entity
(Orig_Node
))
7413 E
: constant Entity_Id
:= Entity
(Orig_Node
);
7414 K
: constant Entity_Kind
:= Ekind
(E
);
7417 return (K
= E_Variable
7418 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
7419 or else (K
= E_Component
7420 and then not In_Protected_Function
(E
))
7421 or else K
= E_Out_Parameter
7422 or else K
= E_In_Out_Parameter
7423 or else K
= E_Generic_In_Out_Parameter
7425 -- Current instance of type:
7427 or else (Is_Type
(E
) and then In_Open_Scopes
(E
))
7428 or else (Is_Incomplete_Or_Private_Type
(E
)
7429 and then In_Open_Scopes
(Full_View
(E
)));
7433 case Nkind
(Orig_Node
) is
7434 when N_Indexed_Component | N_Slice
=>
7435 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
7437 when N_Selected_Component
=>
7438 return Is_Variable_Prefix
(Prefix
(Orig_Node
))
7439 and then Is_Variable
(Selector_Name
(Orig_Node
));
7441 -- For an explicit dereference, the type of the prefix cannot
7442 -- be an access to constant or an access to subprogram.
7444 when N_Explicit_Dereference
=>
7446 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
7448 return Is_Access_Type
(Typ
)
7449 and then not Is_Access_Constant
(Root_Type
(Typ
))
7450 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
7453 -- The type conversion is the case where we do not deal with the
7454 -- context dependent special case of an actual parameter. Thus
7455 -- the type conversion is only considered a variable for the
7456 -- purposes of this routine if the target type is tagged. However,
7457 -- a type conversion is considered to be a variable if it does not
7458 -- come from source (this deals for example with the conversions
7459 -- of expressions to their actual subtypes).
7461 when N_Type_Conversion
=>
7462 return Is_Variable
(Expression
(Orig_Node
))
7464 (not Comes_From_Source
(Orig_Node
)
7466 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
7468 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
7470 -- GNAT allows an unchecked type conversion as a variable. This
7471 -- only affects the generation of internal expanded code, since
7472 -- calls to instantiations of Unchecked_Conversion are never
7473 -- considered variables (since they are function calls).
7474 -- This is also true for expression actions.
7476 when N_Unchecked_Type_Conversion
=>
7477 return Is_Variable
(Expression
(Orig_Node
));
7485 ---------------------------
7486 -- Is_Visibly_Controlled --
7487 ---------------------------
7489 function Is_Visibly_Controlled
(T
: Entity_Id
) return Boolean is
7490 Root
: constant Entity_Id
:= Root_Type
(T
);
7492 return Chars
(Scope
(Root
)) = Name_Finalization
7493 and then Chars
(Scope
(Scope
(Root
))) = Name_Ada
7494 and then Scope
(Scope
(Scope
(Root
))) = Standard_Standard
;
7495 end Is_Visibly_Controlled
;
7497 ------------------------
7498 -- Is_Volatile_Object --
7499 ------------------------
7501 function Is_Volatile_Object
(N
: Node_Id
) return Boolean is
7503 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean;
7504 -- Determines if given object has volatile components
7506 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean;
7507 -- If prefix is an implicit dereference, examine designated type
7509 ------------------------
7510 -- Is_Volatile_Prefix --
7511 ------------------------
7513 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean is
7514 Typ
: constant Entity_Id
:= Etype
(N
);
7517 if Is_Access_Type
(Typ
) then
7519 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
7522 return Is_Volatile
(Dtyp
)
7523 or else Has_Volatile_Components
(Dtyp
);
7527 return Object_Has_Volatile_Components
(N
);
7529 end Is_Volatile_Prefix
;
7531 ------------------------------------
7532 -- Object_Has_Volatile_Components --
7533 ------------------------------------
7535 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean is
7536 Typ
: constant Entity_Id
:= Etype
(N
);
7539 if Is_Volatile
(Typ
)
7540 or else Has_Volatile_Components
(Typ
)
7544 elsif Is_Entity_Name
(N
)
7545 and then (Has_Volatile_Components
(Entity
(N
))
7546 or else Is_Volatile
(Entity
(N
)))
7550 elsif Nkind
(N
) = N_Indexed_Component
7551 or else Nkind
(N
) = N_Selected_Component
7553 return Is_Volatile_Prefix
(Prefix
(N
));
7558 end Object_Has_Volatile_Components
;
7560 -- Start of processing for Is_Volatile_Object
7563 if Is_Volatile
(Etype
(N
))
7564 or else (Is_Entity_Name
(N
) and then Is_Volatile
(Entity
(N
)))
7568 elsif Nkind
(N
) = N_Indexed_Component
7569 or else Nkind
(N
) = N_Selected_Component
7571 return Is_Volatile_Prefix
(Prefix
(N
));
7576 end Is_Volatile_Object
;
7578 -------------------------
7579 -- Kill_Current_Values --
7580 -------------------------
7582 procedure Kill_Current_Values
7584 Last_Assignment_Only
: Boolean := False)
7587 -- ??? do we have to worry about clearing cached checks?
7589 if Is_Assignable
(Ent
) then
7590 Set_Last_Assignment
(Ent
, Empty
);
7593 if Is_Object
(Ent
) then
7594 if not Last_Assignment_Only
then
7596 Set_Current_Value
(Ent
, Empty
);
7598 if not Can_Never_Be_Null
(Ent
) then
7599 Set_Is_Known_Non_Null
(Ent
, False);
7602 Set_Is_Known_Null
(Ent
, False);
7604 -- Reset Is_Known_Valid unless type is always valid, or if we have
7605 -- a loop parameter (loop parameters are always valid, since their
7606 -- bounds are defined by the bounds given in the loop header).
7608 if not Is_Known_Valid
(Etype
(Ent
))
7609 and then Ekind
(Ent
) /= E_Loop_Parameter
7611 Set_Is_Known_Valid
(Ent
, False);
7615 end Kill_Current_Values
;
7617 procedure Kill_Current_Values
(Last_Assignment_Only
: Boolean := False) is
7620 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
);
7621 -- Clear current value for entity E and all entities chained to E
7623 ------------------------------------------
7624 -- Kill_Current_Values_For_Entity_Chain --
7625 ------------------------------------------
7627 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
) is
7631 while Present
(Ent
) loop
7632 Kill_Current_Values
(Ent
, Last_Assignment_Only
);
7635 end Kill_Current_Values_For_Entity_Chain
;
7637 -- Start of processing for Kill_Current_Values
7640 -- Kill all saved checks, a special case of killing saved values
7642 if not Last_Assignment_Only
then
7646 -- Loop through relevant scopes, which includes the current scope and
7647 -- any parent scopes if the current scope is a block or a package.
7652 -- Clear current values of all entities in current scope
7654 Kill_Current_Values_For_Entity_Chain
(First_Entity
(S
));
7656 -- If scope is a package, also clear current values of all
7657 -- private entities in the scope.
7659 if Is_Package_Or_Generic_Package
(S
)
7660 or else Is_Concurrent_Type
(S
)
7662 Kill_Current_Values_For_Entity_Chain
(First_Private_Entity
(S
));
7665 -- If this is a not a subprogram, deal with parents
7667 if not Is_Subprogram
(S
) then
7669 exit Scope_Loop
when S
= Standard_Standard
;
7673 end loop Scope_Loop
;
7674 end Kill_Current_Values
;
7676 --------------------------
7677 -- Kill_Size_Check_Code --
7678 --------------------------
7680 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
7682 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
7683 and then Present
(Size_Check_Code
(E
))
7685 Remove
(Size_Check_Code
(E
));
7686 Set_Size_Check_Code
(E
, Empty
);
7688 end Kill_Size_Check_Code
;
7690 --------------------------
7691 -- Known_To_Be_Assigned --
7692 --------------------------
7694 function Known_To_Be_Assigned
(N
: Node_Id
) return Boolean is
7695 P
: constant Node_Id
:= Parent
(N
);
7700 -- Test left side of assignment
7702 when N_Assignment_Statement
=>
7703 return N
= Name
(P
);
7705 -- Function call arguments are never lvalues
7707 when N_Function_Call
=>
7710 -- Positional parameter for procedure or accept call
7712 when N_Procedure_Call_Statement |
7721 Proc
:= Get_Subprogram_Entity
(P
);
7727 -- If we are not a list member, something is strange, so
7728 -- be conservative and return False.
7730 if not Is_List_Member
(N
) then
7734 -- We are going to find the right formal by stepping forward
7735 -- through the formals, as we step backwards in the actuals.
7737 Form
:= First_Formal
(Proc
);
7740 -- If no formal, something is weird, so be conservative
7741 -- and return False.
7752 return Ekind
(Form
) /= E_In_Parameter
;
7755 -- Named parameter for procedure or accept call
7757 when N_Parameter_Association
=>
7763 Proc
:= Get_Subprogram_Entity
(Parent
(P
));
7769 -- Loop through formals to find the one that matches
7771 Form
:= First_Formal
(Proc
);
7773 -- If no matching formal, that's peculiar, some kind of
7774 -- previous error, so return False to be conservative.
7780 -- Else test for match
7782 if Chars
(Form
) = Chars
(Selector_Name
(P
)) then
7783 return Ekind
(Form
) /= E_In_Parameter
;
7790 -- Test for appearing in a conversion that itself appears
7791 -- in an lvalue context, since this should be an lvalue.
7793 when N_Type_Conversion
=>
7794 return Known_To_Be_Assigned
(P
);
7796 -- All other references are definitely not known to be modifications
7802 end Known_To_Be_Assigned
;
7808 function May_Be_Lvalue
(N
: Node_Id
) return Boolean is
7809 P
: constant Node_Id
:= Parent
(N
);
7814 -- Test left side of assignment
7816 when N_Assignment_Statement
=>
7817 return N
= Name
(P
);
7819 -- Test prefix of component or attribute. Note that the prefix of an
7820 -- explicit or implicit dereference cannot be an l-value.
7822 when N_Attribute_Reference
=>
7823 return N
= Prefix
(P
)
7824 and then Name_Implies_Lvalue_Prefix
(Attribute_Name
(P
));
7826 -- For an expanded name, the name is an lvalue if the expanded name
7827 -- is an lvalue, but the prefix is never an lvalue, since it is just
7828 -- the scope where the name is found.
7830 when N_Expanded_Name
=>
7831 if N
= Prefix
(P
) then
7832 return May_Be_Lvalue
(P
);
7837 -- For a selected component A.B, A is certainly an lvalue if A.B is.
7838 -- B is a little interesting, if we have A.B := 3, there is some
7839 -- discussion as to whether B is an lvalue or not, we choose to say
7840 -- it is. Note however that A is not an lvalue if it is of an access
7841 -- type since this is an implicit dereference.
7843 when N_Selected_Component
=>
7845 and then Present
(Etype
(N
))
7846 and then Is_Access_Type
(Etype
(N
))
7850 return May_Be_Lvalue
(P
);
7853 -- For an indexed component or slice, the index or slice bounds is
7854 -- never an lvalue. The prefix is an lvalue if the indexed component
7855 -- or slice is an lvalue, except if it is an access type, where we
7856 -- have an implicit dereference.
7858 when N_Indexed_Component
=>
7860 or else (Present
(Etype
(N
)) and then Is_Access_Type
(Etype
(N
)))
7864 return May_Be_Lvalue
(P
);
7867 -- Prefix of a reference is an lvalue if the reference is an lvalue
7870 return May_Be_Lvalue
(P
);
7872 -- Prefix of explicit dereference is never an lvalue
7874 when N_Explicit_Dereference
=>
7877 -- Function call arguments are never lvalues
7879 when N_Function_Call
=>
7882 -- Positional parameter for procedure, entry, or accept call
7884 when N_Procedure_Call_Statement |
7885 N_Entry_Call_Statement |
7894 Proc
:= Get_Subprogram_Entity
(P
);
7900 -- If we are not a list member, something is strange, so
7901 -- be conservative and return True.
7903 if not Is_List_Member
(N
) then
7907 -- We are going to find the right formal by stepping forward
7908 -- through the formals, as we step backwards in the actuals.
7910 Form
:= First_Formal
(Proc
);
7913 -- If no formal, something is weird, so be conservative
7925 return Ekind
(Form
) /= E_In_Parameter
;
7928 -- Named parameter for procedure or accept call
7930 when N_Parameter_Association
=>
7936 Proc
:= Get_Subprogram_Entity
(Parent
(P
));
7942 -- Loop through formals to find the one that matches
7944 Form
:= First_Formal
(Proc
);
7946 -- If no matching formal, that's peculiar, some kind of
7947 -- previous error, so return True to be conservative.
7953 -- Else test for match
7955 if Chars
(Form
) = Chars
(Selector_Name
(P
)) then
7956 return Ekind
(Form
) /= E_In_Parameter
;
7963 -- Test for appearing in a conversion that itself appears in an
7964 -- lvalue context, since this should be an lvalue.
7966 when N_Type_Conversion
=>
7967 return May_Be_Lvalue
(P
);
7969 -- Test for appearance in object renaming declaration
7971 when N_Object_Renaming_Declaration
=>
7974 -- All other references are definitely not lvalues
7982 -----------------------
7983 -- Mark_Coextensions --
7984 -----------------------
7986 procedure Mark_Coextensions
(Context_Nod
: Node_Id
; Root_Nod
: Node_Id
) is
7987 Is_Dynamic
: Boolean;
7988 -- Indicates whether the context causes nested coextensions to be
7989 -- dynamic or static
7991 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
;
7992 -- Recognize an allocator node and label it as a dynamic coextension
7994 --------------------
7995 -- Mark_Allocator --
7996 --------------------
7998 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
is
8000 if Nkind
(N
) = N_Allocator
then
8002 Set_Is_Dynamic_Coextension
(N
);
8004 -- If the allocator expression is potentially dynamic, it may
8005 -- be expanded out of order and require dynamic allocation
8006 -- anyway, so we treat the coextension itself as dynamic.
8007 -- Potential optimization ???
8009 elsif Nkind
(Expression
(N
)) = N_Qualified_Expression
8010 and then Nkind
(Expression
(Expression
(N
))) = N_Op_Concat
8012 Set_Is_Dynamic_Coextension
(N
);
8015 Set_Is_Static_Coextension
(N
);
8022 procedure Mark_Allocators
is new Traverse_Proc
(Mark_Allocator
);
8024 -- Start of processing Mark_Coextensions
8027 case Nkind
(Context_Nod
) is
8028 when N_Assignment_Statement |
8029 N_Simple_Return_Statement
=>
8030 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) = N_Allocator
;
8032 when N_Object_Declaration
=>
8033 Is_Dynamic
:= Nkind
(Root_Nod
) = N_Allocator
;
8035 -- This routine should not be called for constructs which may not
8036 -- contain coextensions.
8039 raise Program_Error
;
8042 Mark_Allocators
(Root_Nod
);
8043 end Mark_Coextensions
;
8045 ----------------------
8046 -- Needs_One_Actual --
8047 ----------------------
8049 function Needs_One_Actual
(E
: Entity_Id
) return Boolean is
8053 if Ada_Version
>= Ada_05
8054 and then Present
(First_Formal
(E
))
8056 Formal
:= Next_Formal
(First_Formal
(E
));
8057 while Present
(Formal
) loop
8058 if No
(Default_Value
(Formal
)) then
8062 Next_Formal
(Formal
);
8070 end Needs_One_Actual
;
8072 ------------------------
8073 -- New_Copy_List_Tree --
8074 ------------------------
8076 function New_Copy_List_Tree
(List
: List_Id
) return List_Id
is
8081 if List
= No_List
then
8088 while Present
(E
) loop
8089 Append
(New_Copy_Tree
(E
), NL
);
8095 end New_Copy_List_Tree
;
8101 use Atree
.Unchecked_Access
;
8102 use Atree_Private_Part
;
8104 -- Our approach here requires a two pass traversal of the tree. The
8105 -- first pass visits all nodes that eventually will be copied looking
8106 -- for defining Itypes. If any defining Itypes are found, then they are
8107 -- copied, and an entry is added to the replacement map. In the second
8108 -- phase, the tree is copied, using the replacement map to replace any
8109 -- Itype references within the copied tree.
8111 -- The following hash tables are used if the Map supplied has more
8112 -- than hash threshhold entries to speed up access to the map. If
8113 -- there are fewer entries, then the map is searched sequentially
8114 -- (because setting up a hash table for only a few entries takes
8115 -- more time than it saves.
8117 function New_Copy_Hash
(E
: Entity_Id
) return NCT_Header_Num
;
8118 -- Hash function used for hash operations
8124 function New_Copy_Hash
(E
: Entity_Id
) return NCT_Header_Num
is
8126 return Nat
(E
) mod (NCT_Header_Num
'Last + 1);
8133 -- The hash table NCT_Assoc associates old entities in the table
8134 -- with their corresponding new entities (i.e. the pairs of entries
8135 -- presented in the original Map argument are Key-Element pairs).
8137 package NCT_Assoc
is new Simple_HTable
(
8138 Header_Num
=> NCT_Header_Num
,
8139 Element
=> Entity_Id
,
8140 No_Element
=> Empty
,
8142 Hash
=> New_Copy_Hash
,
8143 Equal
=> Types
."=");
8145 ---------------------
8146 -- NCT_Itype_Assoc --
8147 ---------------------
8149 -- The hash table NCT_Itype_Assoc contains entries only for those
8150 -- old nodes which have a non-empty Associated_Node_For_Itype set.
8151 -- The key is the associated node, and the element is the new node
8152 -- itself (NOT the associated node for the new node).
8154 package NCT_Itype_Assoc
is new Simple_HTable
(
8155 Header_Num
=> NCT_Header_Num
,
8156 Element
=> Entity_Id
,
8157 No_Element
=> Empty
,
8159 Hash
=> New_Copy_Hash
,
8160 Equal
=> Types
."=");
8162 -- Start of processing for New_Copy_Tree function
8164 function New_Copy_Tree
8166 Map
: Elist_Id
:= No_Elist
;
8167 New_Sloc
: Source_Ptr
:= No_Location
;
8168 New_Scope
: Entity_Id
:= Empty
) return Node_Id
8170 Actual_Map
: Elist_Id
:= Map
;
8171 -- This is the actual map for the copy. It is initialized with the
8172 -- given elements, and then enlarged as required for Itypes that are
8173 -- copied during the first phase of the copy operation. The visit
8174 -- procedures add elements to this map as Itypes are encountered.
8175 -- The reason we cannot use Map directly, is that it may well be
8176 -- (and normally is) initialized to No_Elist, and if we have mapped
8177 -- entities, we have to reset it to point to a real Elist.
8179 function Assoc
(N
: Node_Or_Entity_Id
) return Node_Id
;
8180 -- Called during second phase to map entities into their corresponding
8181 -- copies using Actual_Map. If the argument is not an entity, or is not
8182 -- in Actual_Map, then it is returned unchanged.
8184 procedure Build_NCT_Hash_Tables
;
8185 -- Builds hash tables (number of elements >= threshold value)
8187 function Copy_Elist_With_Replacement
8188 (Old_Elist
: Elist_Id
) return Elist_Id
;
8189 -- Called during second phase to copy element list doing replacements
8191 procedure Copy_Itype_With_Replacement
(New_Itype
: Entity_Id
);
8192 -- Called during the second phase to process a copied Itype. The actual
8193 -- copy happened during the first phase (so that we could make the entry
8194 -- in the mapping), but we still have to deal with the descendents of
8195 -- the copied Itype and copy them where necessary.
8197 function Copy_List_With_Replacement
(Old_List
: List_Id
) return List_Id
;
8198 -- Called during second phase to copy list doing replacements
8200 function Copy_Node_With_Replacement
(Old_Node
: Node_Id
) return Node_Id
;
8201 -- Called during second phase to copy node doing replacements
8203 procedure Visit_Elist
(E
: Elist_Id
);
8204 -- Called during first phase to visit all elements of an Elist
8206 procedure Visit_Field
(F
: Union_Id
; N
: Node_Id
);
8207 -- Visit a single field, recursing to call Visit_Node or Visit_List
8208 -- if the field is a syntactic descendent of the current node (i.e.
8209 -- its parent is Node N).
8211 procedure Visit_Itype
(Old_Itype
: Entity_Id
);
8212 -- Called during first phase to visit subsidiary fields of a defining
8213 -- Itype, and also create a copy and make an entry in the replacement
8214 -- map for the new copy.
8216 procedure Visit_List
(L
: List_Id
);
8217 -- Called during first phase to visit all elements of a List
8219 procedure Visit_Node
(N
: Node_Or_Entity_Id
);
8220 -- Called during first phase to visit a node and all its subtrees
8226 function Assoc
(N
: Node_Or_Entity_Id
) return Node_Id
is
8231 if not Has_Extension
(N
) or else No
(Actual_Map
) then
8234 elsif NCT_Hash_Tables_Used
then
8235 Ent
:= NCT_Assoc
.Get
(Entity_Id
(N
));
8237 if Present
(Ent
) then
8243 -- No hash table used, do serial search
8246 E
:= First_Elmt
(Actual_Map
);
8247 while Present
(E
) loop
8248 if Node
(E
) = N
then
8249 return Node
(Next_Elmt
(E
));
8251 E
:= Next_Elmt
(Next_Elmt
(E
));
8259 ---------------------------
8260 -- Build_NCT_Hash_Tables --
8261 ---------------------------
8263 procedure Build_NCT_Hash_Tables
is
8267 if NCT_Hash_Table_Setup
then
8269 NCT_Itype_Assoc
.Reset
;
8272 Elmt
:= First_Elmt
(Actual_Map
);
8273 while Present
(Elmt
) loop
8276 -- Get new entity, and associate old and new
8279 NCT_Assoc
.Set
(Ent
, Node
(Elmt
));
8281 if Is_Type
(Ent
) then
8283 Anode
: constant Entity_Id
:=
8284 Associated_Node_For_Itype
(Ent
);
8287 if Present
(Anode
) then
8289 -- Enter a link between the associated node of the
8290 -- old Itype and the new Itype, for updating later
8291 -- when node is copied.
8293 NCT_Itype_Assoc
.Set
(Anode
, Node
(Elmt
));
8301 NCT_Hash_Tables_Used
:= True;
8302 NCT_Hash_Table_Setup
:= True;
8303 end Build_NCT_Hash_Tables
;
8305 ---------------------------------
8306 -- Copy_Elist_With_Replacement --
8307 ---------------------------------
8309 function Copy_Elist_With_Replacement
8310 (Old_Elist
: Elist_Id
) return Elist_Id
8313 New_Elist
: Elist_Id
;
8316 if No
(Old_Elist
) then
8320 New_Elist
:= New_Elmt_List
;
8322 M
:= First_Elmt
(Old_Elist
);
8323 while Present
(M
) loop
8324 Append_Elmt
(Copy_Node_With_Replacement
(Node
(M
)), New_Elist
);
8330 end Copy_Elist_With_Replacement
;
8332 ---------------------------------
8333 -- Copy_Itype_With_Replacement --
8334 ---------------------------------
8336 -- This routine exactly parallels its phase one analog Visit_Itype,
8338 procedure Copy_Itype_With_Replacement
(New_Itype
: Entity_Id
) is
8340 -- Translate Next_Entity, Scope and Etype fields, in case they
8341 -- reference entities that have been mapped into copies.
8343 Set_Next_Entity
(New_Itype
, Assoc
(Next_Entity
(New_Itype
)));
8344 Set_Etype
(New_Itype
, Assoc
(Etype
(New_Itype
)));
8346 if Present
(New_Scope
) then
8347 Set_Scope
(New_Itype
, New_Scope
);
8349 Set_Scope
(New_Itype
, Assoc
(Scope
(New_Itype
)));
8352 -- Copy referenced fields
8354 if Is_Discrete_Type
(New_Itype
) then
8355 Set_Scalar_Range
(New_Itype
,
8356 Copy_Node_With_Replacement
(Scalar_Range
(New_Itype
)));
8358 elsif Has_Discriminants
(Base_Type
(New_Itype
)) then
8359 Set_Discriminant_Constraint
(New_Itype
,
8360 Copy_Elist_With_Replacement
8361 (Discriminant_Constraint
(New_Itype
)));
8363 elsif Is_Array_Type
(New_Itype
) then
8364 if Present
(First_Index
(New_Itype
)) then
8365 Set_First_Index
(New_Itype
,
8366 First
(Copy_List_With_Replacement
8367 (List_Containing
(First_Index
(New_Itype
)))));
8370 if Is_Packed
(New_Itype
) then
8371 Set_Packed_Array_Type
(New_Itype
,
8372 Copy_Node_With_Replacement
8373 (Packed_Array_Type
(New_Itype
)));
8376 end Copy_Itype_With_Replacement
;
8378 --------------------------------
8379 -- Copy_List_With_Replacement --
8380 --------------------------------
8382 function Copy_List_With_Replacement
8383 (Old_List
: List_Id
) return List_Id
8389 if Old_List
= No_List
then
8393 New_List
:= Empty_List
;
8395 E
:= First
(Old_List
);
8396 while Present
(E
) loop
8397 Append
(Copy_Node_With_Replacement
(E
), New_List
);
8403 end Copy_List_With_Replacement
;
8405 --------------------------------
8406 -- Copy_Node_With_Replacement --
8407 --------------------------------
8409 function Copy_Node_With_Replacement
8410 (Old_Node
: Node_Id
) return Node_Id
8414 procedure Adjust_Named_Associations
8415 (Old_Node
: Node_Id
;
8416 New_Node
: Node_Id
);
8417 -- If a call node has named associations, these are chained through
8418 -- the First_Named_Actual, Next_Named_Actual links. These must be
8419 -- propagated separately to the new parameter list, because these
8420 -- are not syntactic fields.
8422 function Copy_Field_With_Replacement
8423 (Field
: Union_Id
) return Union_Id
;
8424 -- Given Field, which is a field of Old_Node, return a copy of it
8425 -- if it is a syntactic field (i.e. its parent is Node), setting
8426 -- the parent of the copy to poit to New_Node. Otherwise returns
8427 -- the field (possibly mapped if it is an entity).
8429 -------------------------------
8430 -- Adjust_Named_Associations --
8431 -------------------------------
8433 procedure Adjust_Named_Associations
8434 (Old_Node
: Node_Id
;
8444 Old_E
:= First
(Parameter_Associations
(Old_Node
));
8445 New_E
:= First
(Parameter_Associations
(New_Node
));
8446 while Present
(Old_E
) loop
8447 if Nkind
(Old_E
) = N_Parameter_Association
8448 and then Present
(Next_Named_Actual
(Old_E
))
8450 if First_Named_Actual
(Old_Node
)
8451 = Explicit_Actual_Parameter
(Old_E
)
8453 Set_First_Named_Actual
8454 (New_Node
, Explicit_Actual_Parameter
(New_E
));
8457 -- Now scan parameter list from the beginning,to locate
8458 -- next named actual, which can be out of order.
8460 Old_Next
:= First
(Parameter_Associations
(Old_Node
));
8461 New_Next
:= First
(Parameter_Associations
(New_Node
));
8463 while Nkind
(Old_Next
) /= N_Parameter_Association
8464 or else Explicit_Actual_Parameter
(Old_Next
)
8465 /= Next_Named_Actual
(Old_E
)
8471 Set_Next_Named_Actual
8472 (New_E
, Explicit_Actual_Parameter
(New_Next
));
8478 end Adjust_Named_Associations
;
8480 ---------------------------------
8481 -- Copy_Field_With_Replacement --
8482 ---------------------------------
8484 function Copy_Field_With_Replacement
8485 (Field
: Union_Id
) return Union_Id
8488 if Field
= Union_Id
(Empty
) then
8491 elsif Field
in Node_Range
then
8493 Old_N
: constant Node_Id
:= Node_Id
(Field
);
8497 -- If syntactic field, as indicated by the parent pointer
8498 -- being set, then copy the referenced node recursively.
8500 if Parent
(Old_N
) = Old_Node
then
8501 New_N
:= Copy_Node_With_Replacement
(Old_N
);
8503 if New_N
/= Old_N
then
8504 Set_Parent
(New_N
, New_Node
);
8507 -- For semantic fields, update possible entity reference
8508 -- from the replacement map.
8511 New_N
:= Assoc
(Old_N
);
8514 return Union_Id
(New_N
);
8517 elsif Field
in List_Range
then
8519 Old_L
: constant List_Id
:= List_Id
(Field
);
8523 -- If syntactic field, as indicated by the parent pointer,
8524 -- then recursively copy the entire referenced list.
8526 if Parent
(Old_L
) = Old_Node
then
8527 New_L
:= Copy_List_With_Replacement
(Old_L
);
8528 Set_Parent
(New_L
, New_Node
);
8530 -- For semantic list, just returned unchanged
8536 return Union_Id
(New_L
);
8539 -- Anything other than a list or a node is returned unchanged
8544 end Copy_Field_With_Replacement
;
8546 -- Start of processing for Copy_Node_With_Replacement
8549 if Old_Node
<= Empty_Or_Error
then
8552 elsif Has_Extension
(Old_Node
) then
8553 return Assoc
(Old_Node
);
8556 New_Node
:= New_Copy
(Old_Node
);
8558 -- If the node we are copying is the associated node of a
8559 -- previously copied Itype, then adjust the associated node
8560 -- of the copy of that Itype accordingly.
8562 if Present
(Actual_Map
) then
8568 -- Case of hash table used
8570 if NCT_Hash_Tables_Used
then
8571 Ent
:= NCT_Itype_Assoc
.Get
(Old_Node
);
8573 if Present
(Ent
) then
8574 Set_Associated_Node_For_Itype
(Ent
, New_Node
);
8577 -- Case of no hash table used
8580 E
:= First_Elmt
(Actual_Map
);
8581 while Present
(E
) loop
8582 if Is_Itype
(Node
(E
))
8584 Old_Node
= Associated_Node_For_Itype
(Node
(E
))
8586 Set_Associated_Node_For_Itype
8587 (Node
(Next_Elmt
(E
)), New_Node
);
8590 E
:= Next_Elmt
(Next_Elmt
(E
));
8596 -- Recursively copy descendents
8599 (New_Node
, Copy_Field_With_Replacement
(Field1
(New_Node
)));
8601 (New_Node
, Copy_Field_With_Replacement
(Field2
(New_Node
)));
8603 (New_Node
, Copy_Field_With_Replacement
(Field3
(New_Node
)));
8605 (New_Node
, Copy_Field_With_Replacement
(Field4
(New_Node
)));
8607 (New_Node
, Copy_Field_With_Replacement
(Field5
(New_Node
)));
8609 -- Adjust Sloc of new node if necessary
8611 if New_Sloc
/= No_Location
then
8612 Set_Sloc
(New_Node
, New_Sloc
);
8614 -- If we adjust the Sloc, then we are essentially making
8615 -- a completely new node, so the Comes_From_Source flag
8616 -- should be reset to the proper default value.
8618 Nodes
.Table
(New_Node
).Comes_From_Source
:=
8619 Default_Node
.Comes_From_Source
;
8622 -- If the node is call and has named associations,
8623 -- set the corresponding links in the copy.
8625 if (Nkind
(Old_Node
) = N_Function_Call
8626 or else Nkind
(Old_Node
) = N_Entry_Call_Statement
8628 Nkind
(Old_Node
) = N_Procedure_Call_Statement
)
8629 and then Present
(First_Named_Actual
(Old_Node
))
8631 Adjust_Named_Associations
(Old_Node
, New_Node
);
8634 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
8635 -- The replacement mechanism applies to entities, and is not used
8636 -- here. Eventually we may need a more general graph-copying
8637 -- routine. For now, do a sequential search to find desired node.
8639 if Nkind
(Old_Node
) = N_Handled_Sequence_Of_Statements
8640 and then Present
(First_Real_Statement
(Old_Node
))
8643 Old_F
: constant Node_Id
:= First_Real_Statement
(Old_Node
);
8647 N1
:= First
(Statements
(Old_Node
));
8648 N2
:= First
(Statements
(New_Node
));
8650 while N1
/= Old_F
loop
8655 Set_First_Real_Statement
(New_Node
, N2
);
8660 -- All done, return copied node
8663 end Copy_Node_With_Replacement
;
8669 procedure Visit_Elist
(E
: Elist_Id
) is
8673 Elmt
:= First_Elmt
(E
);
8675 while Elmt
/= No_Elmt
loop
8676 Visit_Node
(Node
(Elmt
));
8686 procedure Visit_Field
(F
: Union_Id
; N
: Node_Id
) is
8688 if F
= Union_Id
(Empty
) then
8691 elsif F
in Node_Range
then
8693 -- Copy node if it is syntactic, i.e. its parent pointer is
8694 -- set to point to the field that referenced it (certain
8695 -- Itypes will also meet this criterion, which is fine, since
8696 -- these are clearly Itypes that do need to be copied, since
8697 -- we are copying their parent.)
8699 if Parent
(Node_Id
(F
)) = N
then
8700 Visit_Node
(Node_Id
(F
));
8703 -- Another case, if we are pointing to an Itype, then we want
8704 -- to copy it if its associated node is somewhere in the tree
8707 -- Note: the exclusion of self-referential copies is just an
8708 -- optimization, since the search of the already copied list
8709 -- would catch it, but it is a common case (Etype pointing
8710 -- to itself for an Itype that is a base type).
8712 elsif Has_Extension
(Node_Id
(F
))
8713 and then Is_Itype
(Entity_Id
(F
))
8714 and then Node_Id
(F
) /= N
8720 P
:= Associated_Node_For_Itype
(Node_Id
(F
));
8721 while Present
(P
) loop
8723 Visit_Node
(Node_Id
(F
));
8730 -- An Itype whose parent is not being copied definitely
8731 -- should NOT be copied, since it does not belong in any
8732 -- sense to the copied subtree.
8738 elsif F
in List_Range
8739 and then Parent
(List_Id
(F
)) = N
8741 Visit_List
(List_Id
(F
));
8750 procedure Visit_Itype
(Old_Itype
: Entity_Id
) is
8751 New_Itype
: Entity_Id
;
8756 -- Itypes that describe the designated type of access to subprograms
8757 -- have the structure of subprogram declarations, with signatures,
8758 -- etc. Either we duplicate the signatures completely, or choose to
8759 -- share such itypes, which is fine because their elaboration will
8760 -- have no side effects.
8762 if Ekind
(Old_Itype
) = E_Subprogram_Type
then
8766 New_Itype
:= New_Copy
(Old_Itype
);
8768 -- The new Itype has all the attributes of the old one, and
8769 -- we just copy the contents of the entity. However, the back-end
8770 -- needs different names for debugging purposes, so we create a
8771 -- new internal name for it in all cases.
8773 Set_Chars
(New_Itype
, New_Internal_Name
('T'));
8775 -- If our associated node is an entity that has already been copied,
8776 -- then set the associated node of the copy to point to the right
8777 -- copy. If we have copied an Itype that is itself the associated
8778 -- node of some previously copied Itype, then we set the right
8779 -- pointer in the other direction.
8781 if Present
(Actual_Map
) then
8783 -- Case of hash tables used
8785 if NCT_Hash_Tables_Used
then
8787 Ent
:= NCT_Assoc
.Get
(Associated_Node_For_Itype
(Old_Itype
));
8789 if Present
(Ent
) then
8790 Set_Associated_Node_For_Itype
(New_Itype
, Ent
);
8793 Ent
:= NCT_Itype_Assoc
.Get
(Old_Itype
);
8794 if Present
(Ent
) then
8795 Set_Associated_Node_For_Itype
(Ent
, New_Itype
);
8797 -- If the hash table has no association for this Itype and
8798 -- its associated node, enter one now.
8802 (Associated_Node_For_Itype
(Old_Itype
), New_Itype
);
8805 -- Case of hash tables not used
8808 E
:= First_Elmt
(Actual_Map
);
8809 while Present
(E
) loop
8810 if Associated_Node_For_Itype
(Old_Itype
) = Node
(E
) then
8811 Set_Associated_Node_For_Itype
8812 (New_Itype
, Node
(Next_Elmt
(E
)));
8815 if Is_Type
(Node
(E
))
8817 Old_Itype
= Associated_Node_For_Itype
(Node
(E
))
8819 Set_Associated_Node_For_Itype
8820 (Node
(Next_Elmt
(E
)), New_Itype
);
8823 E
:= Next_Elmt
(Next_Elmt
(E
));
8828 if Present
(Freeze_Node
(New_Itype
)) then
8829 Set_Is_Frozen
(New_Itype
, False);
8830 Set_Freeze_Node
(New_Itype
, Empty
);
8833 -- Add new association to map
8835 if No
(Actual_Map
) then
8836 Actual_Map
:= New_Elmt_List
;
8839 Append_Elmt
(Old_Itype
, Actual_Map
);
8840 Append_Elmt
(New_Itype
, Actual_Map
);
8842 if NCT_Hash_Tables_Used
then
8843 NCT_Assoc
.Set
(Old_Itype
, New_Itype
);
8846 NCT_Table_Entries
:= NCT_Table_Entries
+ 1;
8848 if NCT_Table_Entries
> NCT_Hash_Threshhold
then
8849 Build_NCT_Hash_Tables
;
8853 -- If a record subtype is simply copied, the entity list will be
8854 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
8856 if Ekind_In
(Old_Itype
, E_Record_Subtype
, E_Class_Wide_Subtype
) then
8857 Set_Cloned_Subtype
(New_Itype
, Old_Itype
);
8860 -- Visit descendents that eventually get copied
8862 Visit_Field
(Union_Id
(Etype
(Old_Itype
)), Old_Itype
);
8864 if Is_Discrete_Type
(Old_Itype
) then
8865 Visit_Field
(Union_Id
(Scalar_Range
(Old_Itype
)), Old_Itype
);
8867 elsif Has_Discriminants
(Base_Type
(Old_Itype
)) then
8868 -- ??? This should involve call to Visit_Field
8869 Visit_Elist
(Discriminant_Constraint
(Old_Itype
));
8871 elsif Is_Array_Type
(Old_Itype
) then
8872 if Present
(First_Index
(Old_Itype
)) then
8873 Visit_Field
(Union_Id
(List_Containing
8874 (First_Index
(Old_Itype
))),
8878 if Is_Packed
(Old_Itype
) then
8879 Visit_Field
(Union_Id
(Packed_Array_Type
(Old_Itype
)),
8889 procedure Visit_List
(L
: List_Id
) is
8892 if L
/= No_List
then
8895 while Present
(N
) loop
8906 procedure Visit_Node
(N
: Node_Or_Entity_Id
) is
8908 -- Start of processing for Visit_Node
8911 -- Handle case of an Itype, which must be copied
8913 if Has_Extension
(N
)
8914 and then Is_Itype
(N
)
8916 -- Nothing to do if already in the list. This can happen with an
8917 -- Itype entity that appears more than once in the tree.
8918 -- Note that we do not want to visit descendents in this case.
8920 -- Test for already in list when hash table is used
8922 if NCT_Hash_Tables_Used
then
8923 if Present
(NCT_Assoc
.Get
(Entity_Id
(N
))) then
8927 -- Test for already in list when hash table not used
8933 if Present
(Actual_Map
) then
8934 E
:= First_Elmt
(Actual_Map
);
8935 while Present
(E
) loop
8936 if Node
(E
) = N
then
8939 E
:= Next_Elmt
(Next_Elmt
(E
));
8949 -- Visit descendents
8951 Visit_Field
(Field1
(N
), N
);
8952 Visit_Field
(Field2
(N
), N
);
8953 Visit_Field
(Field3
(N
), N
);
8954 Visit_Field
(Field4
(N
), N
);
8955 Visit_Field
(Field5
(N
), N
);
8958 -- Start of processing for New_Copy_Tree
8963 -- See if we should use hash table
8965 if No
(Actual_Map
) then
8966 NCT_Hash_Tables_Used
:= False;
8973 NCT_Table_Entries
:= 0;
8975 Elmt
:= First_Elmt
(Actual_Map
);
8976 while Present
(Elmt
) loop
8977 NCT_Table_Entries
:= NCT_Table_Entries
+ 1;
8982 if NCT_Table_Entries
> NCT_Hash_Threshhold
then
8983 Build_NCT_Hash_Tables
;
8985 NCT_Hash_Tables_Used
:= False;
8990 -- Hash table set up if required, now start phase one by visiting
8991 -- top node (we will recursively visit the descendents).
8993 Visit_Node
(Source
);
8995 -- Now the second phase of the copy can start. First we process
8996 -- all the mapped entities, copying their descendents.
8998 if Present
(Actual_Map
) then
9001 New_Itype
: Entity_Id
;
9003 Elmt
:= First_Elmt
(Actual_Map
);
9004 while Present
(Elmt
) loop
9006 New_Itype
:= Node
(Elmt
);
9007 Copy_Itype_With_Replacement
(New_Itype
);
9013 -- Now we can copy the actual tree
9015 return Copy_Node_With_Replacement
(Source
);
9018 -------------------------
9019 -- New_External_Entity --
9020 -------------------------
9022 function New_External_Entity
9023 (Kind
: Entity_Kind
;
9024 Scope_Id
: Entity_Id
;
9025 Sloc_Value
: Source_Ptr
;
9026 Related_Id
: Entity_Id
;
9028 Suffix_Index
: Nat
:= 0;
9029 Prefix
: Character := ' ') return Entity_Id
9031 N
: constant Entity_Id
:=
9032 Make_Defining_Identifier
(Sloc_Value
,
9034 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
9037 Set_Ekind
(N
, Kind
);
9038 Set_Is_Internal
(N
, True);
9039 Append_Entity
(N
, Scope_Id
);
9040 Set_Public_Status
(N
);
9042 if Kind
in Type_Kind
then
9043 Init_Size_Align
(N
);
9047 end New_External_Entity
;
9049 -------------------------
9050 -- New_Internal_Entity --
9051 -------------------------
9053 function New_Internal_Entity
9054 (Kind
: Entity_Kind
;
9055 Scope_Id
: Entity_Id
;
9056 Sloc_Value
: Source_Ptr
;
9057 Id_Char
: Character) return Entity_Id
9059 N
: constant Entity_Id
:= Make_Temporary
(Sloc_Value
, Id_Char
);
9062 Set_Ekind
(N
, Kind
);
9063 Set_Is_Internal
(N
, True);
9064 Append_Entity
(N
, Scope_Id
);
9066 if Kind
in Type_Kind
then
9067 Init_Size_Align
(N
);
9071 end New_Internal_Entity
;
9077 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
9081 -- If we are pointing at a positional parameter, it is a member of a
9082 -- node list (the list of parameters), and the next parameter is the
9083 -- next node on the list, unless we hit a parameter association, then
9084 -- we shift to using the chain whose head is the First_Named_Actual in
9085 -- the parent, and then is threaded using the Next_Named_Actual of the
9086 -- Parameter_Association. All this fiddling is because the original node
9087 -- list is in the textual call order, and what we need is the
9088 -- declaration order.
9090 if Is_List_Member
(Actual_Id
) then
9091 N
:= Next
(Actual_Id
);
9093 if Nkind
(N
) = N_Parameter_Association
then
9094 return First_Named_Actual
(Parent
(Actual_Id
));
9100 return Next_Named_Actual
(Parent
(Actual_Id
));
9104 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
9106 Actual_Id
:= Next_Actual
(Actual_Id
);
9109 -----------------------
9110 -- Normalize_Actuals --
9111 -----------------------
9113 -- Chain actuals according to formals of subprogram. If there are no named
9114 -- associations, the chain is simply the list of Parameter Associations,
9115 -- since the order is the same as the declaration order. If there are named
9116 -- associations, then the First_Named_Actual field in the N_Function_Call
9117 -- or N_Procedure_Call_Statement node points to the Parameter_Association
9118 -- node for the parameter that comes first in declaration order. The
9119 -- remaining named parameters are then chained in declaration order using
9120 -- Next_Named_Actual.
9122 -- This routine also verifies that the number of actuals is compatible with
9123 -- the number and default values of formals, but performs no type checking
9124 -- (type checking is done by the caller).
9126 -- If the matching succeeds, Success is set to True and the caller proceeds
9127 -- with type-checking. If the match is unsuccessful, then Success is set to
9128 -- False, and the caller attempts a different interpretation, if there is
9131 -- If the flag Report is on, the call is not overloaded, and a failure to
9132 -- match can be reported here, rather than in the caller.
9134 procedure Normalize_Actuals
9138 Success
: out Boolean)
9140 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
9141 Actual
: Node_Id
:= Empty
;
9143 Last
: Node_Id
:= Empty
;
9144 First_Named
: Node_Id
:= Empty
;
9147 Formals_To_Match
: Integer := 0;
9148 Actuals_To_Match
: Integer := 0;
9150 procedure Chain
(A
: Node_Id
);
9151 -- Add named actual at the proper place in the list, using the
9152 -- Next_Named_Actual link.
9154 function Reporting
return Boolean;
9155 -- Determines if an error is to be reported. To report an error, we
9156 -- need Report to be True, and also we do not report errors caused
9157 -- by calls to init procs that occur within other init procs. Such
9158 -- errors must always be cascaded errors, since if all the types are
9159 -- declared correctly, the compiler will certainly build decent calls!
9165 procedure Chain
(A
: Node_Id
) is
9169 -- Call node points to first actual in list
9171 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
9174 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
9178 Set_Next_Named_Actual
(Last
, Empty
);
9185 function Reporting
return Boolean is
9190 elsif not Within_Init_Proc
then
9193 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
9201 -- Start of processing for Normalize_Actuals
9204 if Is_Access_Type
(S
) then
9206 -- The name in the call is a function call that returns an access
9207 -- to subprogram. The designated type has the list of formals.
9209 Formal
:= First_Formal
(Designated_Type
(S
));
9211 Formal
:= First_Formal
(S
);
9214 while Present
(Formal
) loop
9215 Formals_To_Match
:= Formals_To_Match
+ 1;
9216 Next_Formal
(Formal
);
9219 -- Find if there is a named association, and verify that no positional
9220 -- associations appear after named ones.
9222 if Present
(Actuals
) then
9223 Actual
:= First
(Actuals
);
9226 while Present
(Actual
)
9227 and then Nkind
(Actual
) /= N_Parameter_Association
9229 Actuals_To_Match
:= Actuals_To_Match
+ 1;
9233 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
9235 -- Most common case: positional notation, no defaults
9240 elsif Actuals_To_Match
> Formals_To_Match
then
9242 -- Too many actuals: will not work
9245 if Is_Entity_Name
(Name
(N
)) then
9246 Error_Msg_N
("too many arguments in call to&", Name
(N
));
9248 Error_Msg_N
("too many arguments in call", N
);
9256 First_Named
:= Actual
;
9258 while Present
(Actual
) loop
9259 if Nkind
(Actual
) /= N_Parameter_Association
then
9261 ("positional parameters not allowed after named ones", Actual
);
9266 Actuals_To_Match
:= Actuals_To_Match
+ 1;
9272 if Present
(Actuals
) then
9273 Actual
:= First
(Actuals
);
9276 Formal
:= First_Formal
(S
);
9277 while Present
(Formal
) loop
9279 -- Match the formals in order. If the corresponding actual is
9280 -- positional, nothing to do. Else scan the list of named actuals
9281 -- to find the one with the right name.
9284 and then Nkind
(Actual
) /= N_Parameter_Association
9287 Actuals_To_Match
:= Actuals_To_Match
- 1;
9288 Formals_To_Match
:= Formals_To_Match
- 1;
9291 -- For named parameters, search the list of actuals to find
9292 -- one that matches the next formal name.
9294 Actual
:= First_Named
;
9296 while Present
(Actual
) loop
9297 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
9300 Actuals_To_Match
:= Actuals_To_Match
- 1;
9301 Formals_To_Match
:= Formals_To_Match
- 1;
9309 if Ekind
(Formal
) /= E_In_Parameter
9310 or else No
(Default_Value
(Formal
))
9313 if (Comes_From_Source
(S
)
9314 or else Sloc
(S
) = Standard_Location
)
9315 and then Is_Overloadable
(S
)
9319 (Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
9321 (Nkind
(Parent
(N
)) = N_Function_Call
9323 Nkind
(Parent
(N
)) = N_Parameter_Association
))
9324 and then Ekind
(S
) /= E_Function
9326 Set_Etype
(N
, Etype
(S
));
9328 Error_Msg_Name_1
:= Chars
(S
);
9329 Error_Msg_Sloc
:= Sloc
(S
);
9331 ("missing argument for parameter & " &
9332 "in call to % declared #", N
, Formal
);
9335 elsif Is_Overloadable
(S
) then
9336 Error_Msg_Name_1
:= Chars
(S
);
9338 -- Point to type derivation that generated the
9341 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
9344 ("missing argument for parameter & " &
9345 "in call to % (inherited) #", N
, Formal
);
9349 ("missing argument for parameter &", N
, Formal
);
9357 Formals_To_Match
:= Formals_To_Match
- 1;
9362 Next_Formal
(Formal
);
9365 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
9372 -- Find some superfluous named actual that did not get
9373 -- attached to the list of associations.
9375 Actual
:= First
(Actuals
);
9376 while Present
(Actual
) loop
9377 if Nkind
(Actual
) = N_Parameter_Association
9378 and then Actual
/= Last
9379 and then No
(Next_Named_Actual
(Actual
))
9381 Error_Msg_N
("unmatched actual & in call",
9382 Selector_Name
(Actual
));
9393 end Normalize_Actuals
;
9395 --------------------------------
9396 -- Note_Possible_Modification --
9397 --------------------------------
9399 procedure Note_Possible_Modification
(N
: Node_Id
; Sure
: Boolean) is
9400 Modification_Comes_From_Source
: constant Boolean :=
9401 Comes_From_Source
(Parent
(N
));
9407 -- Loop to find referenced entity, if there is one
9414 if Is_Entity_Name
(Exp
) then
9415 Ent
:= Entity
(Exp
);
9417 -- If the entity is missing, it is an undeclared identifier,
9418 -- and there is nothing to annotate.
9424 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
9426 P
: constant Node_Id
:= Prefix
(Exp
);
9429 if Nkind
(P
) = N_Selected_Component
9431 Entry_Formal
(Entity
(Selector_Name
(P
))))
9433 -- Case of a reference to an entry formal
9435 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
9437 elsif Nkind
(P
) = N_Identifier
9438 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
9439 and then Present
(Expression
(Parent
(Entity
(P
))))
9440 and then Nkind
(Expression
(Parent
(Entity
(P
))))
9443 -- Case of a reference to a value on which side effects have
9446 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
9455 elsif Nkind
(Exp
) = N_Type_Conversion
9456 or else Nkind
(Exp
) = N_Unchecked_Type_Conversion
9458 Exp
:= Expression
(Exp
);
9461 elsif Nkind
(Exp
) = N_Slice
9462 or else Nkind
(Exp
) = N_Indexed_Component
9463 or else Nkind
(Exp
) = N_Selected_Component
9465 Exp
:= Prefix
(Exp
);
9472 -- Now look for entity being referenced
9474 if Present
(Ent
) then
9475 if Is_Object
(Ent
) then
9476 if Comes_From_Source
(Exp
)
9477 or else Modification_Comes_From_Source
9479 if Has_Pragma_Unmodified
(Ent
) then
9480 Error_Msg_NE
("?pragma Unmodified given for &!", N
, Ent
);
9483 Set_Never_Set_In_Source
(Ent
, False);
9486 Set_Is_True_Constant
(Ent
, False);
9487 Set_Current_Value
(Ent
, Empty
);
9488 Set_Is_Known_Null
(Ent
, False);
9490 if not Can_Never_Be_Null
(Ent
) then
9491 Set_Is_Known_Non_Null
(Ent
, False);
9494 -- Follow renaming chain
9496 if (Ekind
(Ent
) = E_Variable
or else Ekind
(Ent
) = E_Constant
)
9497 and then Present
(Renamed_Object
(Ent
))
9499 Exp
:= Renamed_Object
(Ent
);
9503 -- Generate a reference only if the assignment comes from
9504 -- source. This excludes, for example, calls to a dispatching
9505 -- assignment operation when the left-hand side is tagged.
9507 if Modification_Comes_From_Source
then
9508 Generate_Reference
(Ent
, Exp
, 'm');
9511 Check_Nested_Access
(Ent
);
9516 -- If we are sure this is a modification from source, and we know
9517 -- this modifies a constant, then give an appropriate warning.
9519 if Overlays_Constant
(Ent
)
9520 and then Modification_Comes_From_Source
9524 A
: constant Node_Id
:= Address_Clause
(Ent
);
9528 Exp
: constant Node_Id
:= Expression
(A
);
9530 if Nkind
(Exp
) = N_Attribute_Reference
9531 and then Attribute_Name
(Exp
) = Name_Address
9532 and then Is_Entity_Name
(Prefix
(Exp
))
9534 Error_Msg_Sloc
:= Sloc
(A
);
9536 ("constant& may be modified via address clause#?",
9537 N
, Entity
(Prefix
(Exp
)));
9547 end Note_Possible_Modification
;
9549 -------------------------
9550 -- Object_Access_Level --
9551 -------------------------
9553 function Object_Access_Level
(Obj
: Node_Id
) return Uint
is
9556 -- Returns the static accessibility level of the view denoted by Obj. Note
9557 -- that the value returned is the result of a call to Scope_Depth. Only
9558 -- scope depths associated with dynamic scopes can actually be returned.
9559 -- Since only relative levels matter for accessibility checking, the fact
9560 -- that the distance between successive levels of accessibility is not
9561 -- always one is immaterial (invariant: if level(E2) is deeper than
9562 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
9564 function Reference_To
(Obj
: Node_Id
) return Node_Id
;
9565 -- An explicit dereference is created when removing side-effects from
9566 -- expressions for constraint checking purposes. In this case a local
9567 -- access type is created for it. The correct access level is that of
9568 -- the original source node. We detect this case by noting that the
9569 -- prefix of the dereference is created by an object declaration whose
9570 -- initial expression is a reference.
9576 function Reference_To
(Obj
: Node_Id
) return Node_Id
is
9577 Pref
: constant Node_Id
:= Prefix
(Obj
);
9579 if Is_Entity_Name
(Pref
)
9580 and then Nkind
(Parent
(Entity
(Pref
))) = N_Object_Declaration
9581 and then Present
(Expression
(Parent
(Entity
(Pref
))))
9582 and then Nkind
(Expression
(Parent
(Entity
(Pref
)))) = N_Reference
9584 return (Prefix
(Expression
(Parent
(Entity
(Pref
)))));
9590 -- Start of processing for Object_Access_Level
9593 if Is_Entity_Name
(Obj
) then
9596 if Is_Prival
(E
) then
9597 E
:= Prival_Link
(E
);
9600 -- If E is a type then it denotes a current instance. For this case
9601 -- we add one to the normal accessibility level of the type to ensure
9602 -- that current instances are treated as always being deeper than
9603 -- than the level of any visible named access type (see 3.10.2(21)).
9606 return Type_Access_Level
(E
) + 1;
9608 elsif Present
(Renamed_Object
(E
)) then
9609 return Object_Access_Level
(Renamed_Object
(E
));
9611 -- Similarly, if E is a component of the current instance of a
9612 -- protected type, any instance of it is assumed to be at a deeper
9613 -- level than the type. For a protected object (whose type is an
9614 -- anonymous protected type) its components are at the same level
9615 -- as the type itself.
9617 elsif not Is_Overloadable
(E
)
9618 and then Ekind
(Scope
(E
)) = E_Protected_Type
9619 and then Comes_From_Source
(Scope
(E
))
9621 return Type_Access_Level
(Scope
(E
)) + 1;
9624 return Scope_Depth
(Enclosing_Dynamic_Scope
(E
));
9627 elsif Nkind
(Obj
) = N_Selected_Component
then
9628 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
9629 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
9631 return Object_Access_Level
(Prefix
(Obj
));
9634 elsif Nkind
(Obj
) = N_Indexed_Component
then
9635 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
9636 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
9638 return Object_Access_Level
(Prefix
(Obj
));
9641 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
9643 -- If the prefix is a selected access discriminant then we make a
9644 -- recursive call on the prefix, which will in turn check the level
9645 -- of the prefix object of the selected discriminant.
9647 if Nkind
(Prefix
(Obj
)) = N_Selected_Component
9648 and then Ekind
(Etype
(Prefix
(Obj
))) = E_Anonymous_Access_Type
9650 Ekind
(Entity
(Selector_Name
(Prefix
(Obj
)))) = E_Discriminant
9652 return Object_Access_Level
(Prefix
(Obj
));
9654 elsif not (Comes_From_Source
(Obj
)) then
9656 Ref
: constant Node_Id
:= Reference_To
(Obj
);
9658 if Present
(Ref
) then
9659 return Object_Access_Level
(Ref
);
9661 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
9666 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
9669 elsif Nkind
(Obj
) = N_Type_Conversion
9670 or else Nkind
(Obj
) = N_Unchecked_Type_Conversion
9672 return Object_Access_Level
(Expression
(Obj
));
9674 elsif Nkind
(Obj
) = N_Function_Call
then
9676 -- Function results are objects, so we get either the access level of
9677 -- the function or, in the case of an indirect call, the level of the
9678 -- access-to-subprogram type. (This code is used for Ada 95, but it
9679 -- looks wrong, because it seems that we should be checking the level
9680 -- of the call itself, even for Ada 95. However, using the Ada 2005
9681 -- version of the code causes regressions in several tests that are
9682 -- compiled with -gnat95. ???)
9684 if Ada_Version
< Ada_05
then
9685 if Is_Entity_Name
(Name
(Obj
)) then
9686 return Subprogram_Access_Level
(Entity
(Name
(Obj
)));
9688 return Type_Access_Level
(Etype
(Prefix
(Name
(Obj
))));
9691 -- For Ada 2005, the level of the result object of a function call is
9692 -- defined to be the level of the call's innermost enclosing master.
9693 -- We determine that by querying the depth of the innermost enclosing
9697 Return_Master_Scope_Depth_Of_Call
: declare
9699 function Innermost_Master_Scope_Depth
9700 (N
: Node_Id
) return Uint
;
9701 -- Returns the scope depth of the given node's innermost
9702 -- enclosing dynamic scope (effectively the accessibility
9703 -- level of the innermost enclosing master).
9705 ----------------------------------
9706 -- Innermost_Master_Scope_Depth --
9707 ----------------------------------
9709 function Innermost_Master_Scope_Depth
9710 (N
: Node_Id
) return Uint
9712 Node_Par
: Node_Id
:= Parent
(N
);
9715 -- Locate the nearest enclosing node (by traversing Parents)
9716 -- that Defining_Entity can be applied to, and return the
9717 -- depth of that entity's nearest enclosing dynamic scope.
9719 while Present
(Node_Par
) loop
9720 case Nkind
(Node_Par
) is
9721 when N_Component_Declaration |
9722 N_Entry_Declaration |
9723 N_Formal_Object_Declaration |
9724 N_Formal_Type_Declaration |
9725 N_Full_Type_Declaration |
9726 N_Incomplete_Type_Declaration |
9727 N_Loop_Parameter_Specification |
9728 N_Object_Declaration |
9729 N_Protected_Type_Declaration |
9730 N_Private_Extension_Declaration |
9731 N_Private_Type_Declaration |
9732 N_Subtype_Declaration |
9733 N_Function_Specification |
9734 N_Procedure_Specification |
9735 N_Task_Type_Declaration |
9737 N_Generic_Instantiation |
9739 N_Implicit_Label_Declaration |
9740 N_Package_Declaration |
9741 N_Single_Task_Declaration |
9742 N_Subprogram_Declaration |
9743 N_Generic_Declaration |
9744 N_Renaming_Declaration |
9746 N_Formal_Subprogram_Declaration |
9747 N_Abstract_Subprogram_Declaration |
9749 N_Exception_Declaration |
9750 N_Formal_Package_Declaration |
9751 N_Number_Declaration |
9752 N_Package_Specification |
9753 N_Parameter_Specification |
9754 N_Single_Protected_Declaration |
9758 (Nearest_Dynamic_Scope
9759 (Defining_Entity
(Node_Par
)));
9765 Node_Par
:= Parent
(Node_Par
);
9768 pragma Assert
(False);
9770 -- Should never reach the following return
9772 return Scope_Depth
(Current_Scope
) + 1;
9773 end Innermost_Master_Scope_Depth
;
9775 -- Start of processing for Return_Master_Scope_Depth_Of_Call
9778 return Innermost_Master_Scope_Depth
(Obj
);
9779 end Return_Master_Scope_Depth_Of_Call
;
9782 -- For convenience we handle qualified expressions, even though
9783 -- they aren't technically object names.
9785 elsif Nkind
(Obj
) = N_Qualified_Expression
then
9786 return Object_Access_Level
(Expression
(Obj
));
9788 -- Otherwise return the scope level of Standard.
9789 -- (If there are cases that fall through
9790 -- to this point they will be treated as
9791 -- having global accessibility for now. ???)
9794 return Scope_Depth
(Standard_Standard
);
9796 end Object_Access_Level
;
9798 -----------------------
9799 -- Private_Component --
9800 -----------------------
9802 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
9803 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
9805 function Trace_Components
9807 Check
: Boolean) return Entity_Id
;
9808 -- Recursive function that does the work, and checks against circular
9809 -- definition for each subcomponent type.
9811 ----------------------
9812 -- Trace_Components --
9813 ----------------------
9815 function Trace_Components
9817 Check
: Boolean) return Entity_Id
9819 Btype
: constant Entity_Id
:= Base_Type
(T
);
9820 Component
: Entity_Id
;
9822 Candidate
: Entity_Id
:= Empty
;
9825 if Check
and then Btype
= Ancestor
then
9826 Error_Msg_N
("circular type definition", Type_Id
);
9830 if Is_Private_Type
(Btype
)
9831 and then not Is_Generic_Type
(Btype
)
9833 if Present
(Full_View
(Btype
))
9834 and then Is_Record_Type
(Full_View
(Btype
))
9835 and then not Is_Frozen
(Btype
)
9837 -- To indicate that the ancestor depends on a private type, the
9838 -- current Btype is sufficient. However, to check for circular
9839 -- definition we must recurse on the full view.
9841 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
9843 if Candidate
= Any_Type
then
9853 elsif Is_Array_Type
(Btype
) then
9854 return Trace_Components
(Component_Type
(Btype
), True);
9856 elsif Is_Record_Type
(Btype
) then
9857 Component
:= First_Entity
(Btype
);
9858 while Present
(Component
) loop
9860 -- Skip anonymous types generated by constrained components
9862 if not Is_Type
(Component
) then
9863 P
:= Trace_Components
(Etype
(Component
), True);
9866 if P
= Any_Type
then
9874 Next_Entity
(Component
);
9882 end Trace_Components
;
9884 -- Start of processing for Private_Component
9887 return Trace_Components
(Type_Id
, False);
9888 end Private_Component
;
9890 ---------------------------
9891 -- Primitive_Names_Match --
9892 ---------------------------
9894 function Primitive_Names_Match
(E1
, E2
: Entity_Id
) return Boolean is
9896 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
;
9897 -- Given an internal name, returns the corresponding non-internal name
9899 ------------------------
9900 -- Non_Internal_Name --
9901 ------------------------
9903 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
is
9905 Get_Name_String
(Chars
(E
));
9906 Name_Len
:= Name_Len
- 1;
9908 end Non_Internal_Name
;
9910 -- Start of processing for Primitive_Names_Match
9913 pragma Assert
(Present
(E1
) and then Present
(E2
));
9915 return Chars
(E1
) = Chars
(E2
)
9917 (not Is_Internal_Name
(Chars
(E1
))
9918 and then Is_Internal_Name
(Chars
(E2
))
9919 and then Non_Internal_Name
(E2
) = Chars
(E1
))
9921 (not Is_Internal_Name
(Chars
(E2
))
9922 and then Is_Internal_Name
(Chars
(E1
))
9923 and then Non_Internal_Name
(E1
) = Chars
(E2
))
9925 (Is_Predefined_Dispatching_Operation
(E1
)
9926 and then Is_Predefined_Dispatching_Operation
(E2
)
9927 and then Same_TSS
(E1
, E2
))
9929 (Is_Init_Proc
(E1
) and then Is_Init_Proc
(E2
));
9930 end Primitive_Names_Match
;
9932 -----------------------
9933 -- Process_End_Label --
9934 -----------------------
9936 procedure Process_End_Label
9945 Label_Ref
: Boolean;
9946 -- Set True if reference to end label itself is required
9949 -- Gets set to the operator symbol or identifier that references the
9950 -- entity Ent. For the child unit case, this is the identifier from the
9951 -- designator. For other cases, this is simply Endl.
9953 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
);
9954 -- N is an identifier node that appears as a parent unit reference in
9955 -- the case where Ent is a child unit. This procedure generates an
9956 -- appropriate cross-reference entry. E is the corresponding entity.
9958 -------------------------
9959 -- Generate_Parent_Ref --
9960 -------------------------
9962 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
) is
9964 -- If names do not match, something weird, skip reference
9966 if Chars
(E
) = Chars
(N
) then
9968 -- Generate the reference. We do NOT consider this as a reference
9969 -- for unreferenced symbol purposes.
9971 Generate_Reference
(E
, N
, 'r', Set_Ref
=> False, Force
=> True);
9974 Style
.Check_Identifier
(N
, E
);
9977 end Generate_Parent_Ref
;
9979 -- Start of processing for Process_End_Label
9982 -- If no node, ignore. This happens in some error situations, and
9983 -- also for some internally generated structures where no end label
9984 -- references are required in any case.
9990 -- Nothing to do if no End_Label, happens for internally generated
9991 -- constructs where we don't want an end label reference anyway. Also
9992 -- nothing to do if Endl is a string literal, which means there was
9993 -- some prior error (bad operator symbol)
9995 Endl
:= End_Label
(N
);
9997 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
10001 -- Reference node is not in extended main source unit
10003 if not In_Extended_Main_Source_Unit
(N
) then
10005 -- Generally we do not collect references except for the extended
10006 -- main source unit. The one exception is the 'e' entry for a
10007 -- package spec, where it is useful for a client to have the
10008 -- ending information to define scopes.
10014 Label_Ref
:= False;
10016 -- For this case, we can ignore any parent references, but we
10017 -- need the package name itself for the 'e' entry.
10019 if Nkind
(Endl
) = N_Designator
then
10020 Endl
:= Identifier
(Endl
);
10024 -- Reference is in extended main source unit
10029 -- For designator, generate references for the parent entries
10031 if Nkind
(Endl
) = N_Designator
then
10033 -- Generate references for the prefix if the END line comes from
10034 -- source (otherwise we do not need these references) We climb the
10035 -- scope stack to find the expected entities.
10037 if Comes_From_Source
(Endl
) then
10038 Nam
:= Name
(Endl
);
10039 Scop
:= Current_Scope
;
10040 while Nkind
(Nam
) = N_Selected_Component
loop
10041 Scop
:= Scope
(Scop
);
10042 exit when No
(Scop
);
10043 Generate_Parent_Ref
(Selector_Name
(Nam
), Scop
);
10044 Nam
:= Prefix
(Nam
);
10047 if Present
(Scop
) then
10048 Generate_Parent_Ref
(Nam
, Scope
(Scop
));
10052 Endl
:= Identifier
(Endl
);
10056 -- If the end label is not for the given entity, then either we have
10057 -- some previous error, or this is a generic instantiation for which
10058 -- we do not need to make a cross-reference in this case anyway. In
10059 -- either case we simply ignore the call.
10061 if Chars
(Ent
) /= Chars
(Endl
) then
10065 -- If label was really there, then generate a normal reference and then
10066 -- adjust the location in the end label to point past the name (which
10067 -- should almost always be the semicolon).
10069 Loc
:= Sloc
(Endl
);
10071 if Comes_From_Source
(Endl
) then
10073 -- If a label reference is required, then do the style check and
10074 -- generate an l-type cross-reference entry for the label
10077 if Style_Check
then
10078 Style
.Check_Identifier
(Endl
, Ent
);
10081 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
10084 -- Set the location to point past the label (normally this will
10085 -- mean the semicolon immediately following the label). This is
10086 -- done for the sake of the 'e' or 't' entry generated below.
10088 Get_Decoded_Name_String
(Chars
(Endl
));
10089 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
10092 -- Now generate the e/t reference
10094 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
10096 -- Restore Sloc, in case modified above, since we have an identifier
10097 -- and the normal Sloc should be left set in the tree.
10099 Set_Sloc
(Endl
, Loc
);
10100 end Process_End_Label
;
10106 -- We do the conversion to get the value of the real string by using
10107 -- the scanner, see Sinput for details on use of the internal source
10108 -- buffer for scanning internal strings.
10110 function Real_Convert
(S
: String) return Node_Id
is
10111 Save_Src
: constant Source_Buffer_Ptr
:= Source
;
10112 Negative
: Boolean;
10115 Source
:= Internal_Source_Ptr
;
10118 for J
in S
'Range loop
10119 Source
(Source_Ptr
(J
)) := S
(J
);
10122 Source
(S
'Length + 1) := EOF
;
10124 if Source
(Scan_Ptr
) = '-' then
10126 Scan_Ptr
:= Scan_Ptr
+ 1;
10134 Set_Realval
(Token_Node
, UR_Negate
(Realval
(Token_Node
)));
10137 Source
:= Save_Src
;
10141 ------------------------------------
10142 -- References_Generic_Formal_Type --
10143 ------------------------------------
10145 function References_Generic_Formal_Type
(N
: Node_Id
) return Boolean is
10147 function Process
(N
: Node_Id
) return Traverse_Result
;
10148 -- Process one node in search for generic formal type
10154 function Process
(N
: Node_Id
) return Traverse_Result
is
10156 if Nkind
(N
) in N_Has_Entity
then
10158 E
: constant Entity_Id
:= Entity
(N
);
10160 if Present
(E
) then
10161 if Is_Generic_Type
(E
) then
10163 elsif Present
(Etype
(E
))
10164 and then Is_Generic_Type
(Etype
(E
))
10175 function Traverse
is new Traverse_Func
(Process
);
10176 -- Traverse tree to look for generic type
10179 if Inside_A_Generic
then
10180 return Traverse
(N
) = Abandon
;
10184 end References_Generic_Formal_Type
;
10186 --------------------
10187 -- Remove_Homonym --
10188 --------------------
10190 procedure Remove_Homonym
(E
: Entity_Id
) is
10191 Prev
: Entity_Id
:= Empty
;
10195 if E
= Current_Entity
(E
) then
10196 if Present
(Homonym
(E
)) then
10197 Set_Current_Entity
(Homonym
(E
));
10199 Set_Name_Entity_Id
(Chars
(E
), Empty
);
10202 H
:= Current_Entity
(E
);
10203 while Present
(H
) and then H
/= E
loop
10208 Set_Homonym
(Prev
, Homonym
(E
));
10210 end Remove_Homonym
;
10212 ---------------------
10213 -- Rep_To_Pos_Flag --
10214 ---------------------
10216 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
10218 return New_Occurrence_Of
10219 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
10220 end Rep_To_Pos_Flag
;
10222 --------------------
10223 -- Require_Entity --
10224 --------------------
10226 procedure Require_Entity
(N
: Node_Id
) is
10228 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
10229 if Total_Errors_Detected
/= 0 then
10230 Set_Entity
(N
, Any_Id
);
10232 raise Program_Error
;
10235 end Require_Entity
;
10237 ------------------------------
10238 -- Requires_Transient_Scope --
10239 ------------------------------
10241 -- A transient scope is required when variable-sized temporaries are
10242 -- allocated in the primary or secondary stack, or when finalization
10243 -- actions must be generated before the next instruction.
10245 function Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean is
10246 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
10248 -- Start of processing for Requires_Transient_Scope
10251 -- This is a private type which is not completed yet. This can only
10252 -- happen in a default expression (of a formal parameter or of a
10253 -- record component). Do not expand transient scope in this case
10258 -- Do not expand transient scope for non-existent procedure return
10260 elsif Typ
= Standard_Void_Type
then
10263 -- Elementary types do not require a transient scope
10265 elsif Is_Elementary_Type
(Typ
) then
10268 -- Generally, indefinite subtypes require a transient scope, since the
10269 -- back end cannot generate temporaries, since this is not a valid type
10270 -- for declaring an object. It might be possible to relax this in the
10271 -- future, e.g. by declaring the maximum possible space for the type.
10273 elsif Is_Indefinite_Subtype
(Typ
) then
10276 -- Functions returning tagged types may dispatch on result so their
10277 -- returned value is allocated on the secondary stack. Controlled
10278 -- type temporaries need finalization.
10280 elsif Is_Tagged_Type
(Typ
)
10281 or else Has_Controlled_Component
(Typ
)
10283 return not Is_Value_Type
(Typ
);
10287 elsif Is_Record_Type
(Typ
) then
10291 Comp
:= First_Entity
(Typ
);
10292 while Present
(Comp
) loop
10293 if Ekind
(Comp
) = E_Component
10294 and then Requires_Transient_Scope
(Etype
(Comp
))
10298 Next_Entity
(Comp
);
10305 -- String literal types never require transient scope
10307 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
10310 -- Array type. Note that we already know that this is a constrained
10311 -- array, since unconstrained arrays will fail the indefinite test.
10313 elsif Is_Array_Type
(Typ
) then
10315 -- If component type requires a transient scope, the array does too
10317 if Requires_Transient_Scope
(Component_Type
(Typ
)) then
10320 -- Otherwise, we only need a transient scope if the size is not
10321 -- known at compile time.
10324 return not Size_Known_At_Compile_Time
(Typ
);
10327 -- All other cases do not require a transient scope
10332 end Requires_Transient_Scope
;
10334 --------------------------
10335 -- Reset_Analyzed_Flags --
10336 --------------------------
10338 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
10340 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
;
10341 -- Function used to reset Analyzed flags in tree. Note that we do
10342 -- not reset Analyzed flags in entities, since there is no need to
10343 -- reanalyze entities, and indeed, it is wrong to do so, since it
10344 -- can result in generating auxiliary stuff more than once.
10346 --------------------
10347 -- Clear_Analyzed --
10348 --------------------
10350 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
is
10352 if not Has_Extension
(N
) then
10353 Set_Analyzed
(N
, False);
10357 end Clear_Analyzed
;
10359 procedure Reset_Analyzed
is new Traverse_Proc
(Clear_Analyzed
);
10361 -- Start of processing for Reset_Analyzed_Flags
10364 Reset_Analyzed
(N
);
10365 end Reset_Analyzed_Flags
;
10367 ---------------------------
10368 -- Safe_To_Capture_Value --
10369 ---------------------------
10371 function Safe_To_Capture_Value
10374 Cond
: Boolean := False) return Boolean
10377 -- The only entities for which we track constant values are variables
10378 -- which are not renamings, constants, out parameters, and in out
10379 -- parameters, so check if we have this case.
10381 -- Note: it may seem odd to track constant values for constants, but in
10382 -- fact this routine is used for other purposes than simply capturing
10383 -- the value. In particular, the setting of Known[_Non]_Null.
10385 if (Ekind
(Ent
) = E_Variable
and then No
(Renamed_Object
(Ent
)))
10387 Ekind
(Ent
) = E_Constant
10389 Ekind
(Ent
) = E_Out_Parameter
10391 Ekind
(Ent
) = E_In_Out_Parameter
10395 -- For conditionals, we also allow loop parameters and all formals,
10396 -- including in parameters.
10400 (Ekind
(Ent
) = E_Loop_Parameter
10402 Ekind
(Ent
) = E_In_Parameter
)
10406 -- For all other cases, not just unsafe, but impossible to capture
10407 -- Current_Value, since the above are the only entities which have
10408 -- Current_Value fields.
10414 -- Skip if volatile or aliased, since funny things might be going on in
10415 -- these cases which we cannot necessarily track. Also skip any variable
10416 -- for which an address clause is given, or whose address is taken. Also
10417 -- never capture value of library level variables (an attempt to do so
10418 -- can occur in the case of package elaboration code).
10420 if Treat_As_Volatile
(Ent
)
10421 or else Is_Aliased
(Ent
)
10422 or else Present
(Address_Clause
(Ent
))
10423 or else Address_Taken
(Ent
)
10424 or else (Is_Library_Level_Entity
(Ent
)
10425 and then Ekind
(Ent
) = E_Variable
)
10430 -- OK, all above conditions are met. We also require that the scope of
10431 -- the reference be the same as the scope of the entity, not counting
10432 -- packages and blocks and loops.
10435 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
10436 R_Scope
: Entity_Id
;
10439 R_Scope
:= Current_Scope
;
10440 while R_Scope
/= Standard_Standard
loop
10441 exit when R_Scope
= E_Scope
;
10443 if not Ekind_In
(R_Scope
, E_Package
, E_Block
, E_Loop
) then
10446 R_Scope
:= Scope
(R_Scope
);
10451 -- We also require that the reference does not appear in a context
10452 -- where it is not sure to be executed (i.e. a conditional context
10453 -- or an exception handler). We skip this if Cond is True, since the
10454 -- capturing of values from conditional tests handles this ok.
10468 while Present
(P
) loop
10469 if Nkind
(P
) = N_If_Statement
10470 or else Nkind
(P
) = N_Case_Statement
10471 or else (Nkind
(P
) in N_Short_Circuit
10472 and then Desc
= Right_Opnd
(P
))
10473 or else (Nkind
(P
) = N_Conditional_Expression
10474 and then Desc
/= First
(Expressions
(P
)))
10475 or else Nkind
(P
) = N_Exception_Handler
10476 or else Nkind
(P
) = N_Selective_Accept
10477 or else Nkind
(P
) = N_Conditional_Entry_Call
10478 or else Nkind
(P
) = N_Timed_Entry_Call
10479 or else Nkind
(P
) = N_Asynchronous_Select
10489 -- OK, looks safe to set value
10492 end Safe_To_Capture_Value
;
10498 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
10499 K1
: constant Node_Kind
:= Nkind
(N1
);
10500 K2
: constant Node_Kind
:= Nkind
(N2
);
10503 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
10504 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
10506 return Chars
(N1
) = Chars
(N2
);
10508 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
10509 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
10511 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
10512 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
10523 function Same_Object
(Node1
, Node2
: Node_Id
) return Boolean is
10524 N1
: constant Node_Id
:= Original_Node
(Node1
);
10525 N2
: constant Node_Id
:= Original_Node
(Node2
);
10526 -- We do the tests on original nodes, since we are most interested
10527 -- in the original source, not any expansion that got in the way.
10529 K1
: constant Node_Kind
:= Nkind
(N1
);
10530 K2
: constant Node_Kind
:= Nkind
(N2
);
10533 -- First case, both are entities with same entity
10535 if K1
in N_Has_Entity
and then K2
in N_Has_Entity
then
10537 EN1
: constant Entity_Id
:= Entity
(N1
);
10538 EN2
: constant Entity_Id
:= Entity
(N2
);
10540 if Present
(EN1
) and then Present
(EN2
)
10541 and then (Ekind_In
(EN1
, E_Variable
, E_Constant
)
10542 or else Is_Formal
(EN1
))
10550 -- Second case, selected component with same selector, same record
10552 if K1
= N_Selected_Component
10553 and then K2
= N_Selected_Component
10554 and then Chars
(Selector_Name
(N1
)) = Chars
(Selector_Name
(N2
))
10556 return Same_Object
(Prefix
(N1
), Prefix
(N2
));
10558 -- Third case, indexed component with same subscripts, same array
10560 elsif K1
= N_Indexed_Component
10561 and then K2
= N_Indexed_Component
10562 and then Same_Object
(Prefix
(N1
), Prefix
(N2
))
10567 E1
:= First
(Expressions
(N1
));
10568 E2
:= First
(Expressions
(N2
));
10569 while Present
(E1
) loop
10570 if not Same_Value
(E1
, E2
) then
10581 -- Fourth case, slice of same array with same bounds
10584 and then K2
= N_Slice
10585 and then Nkind
(Discrete_Range
(N1
)) = N_Range
10586 and then Nkind
(Discrete_Range
(N2
)) = N_Range
10587 and then Same_Value
(Low_Bound
(Discrete_Range
(N1
)),
10588 Low_Bound
(Discrete_Range
(N2
)))
10589 and then Same_Value
(High_Bound
(Discrete_Range
(N1
)),
10590 High_Bound
(Discrete_Range
(N2
)))
10592 return Same_Name
(Prefix
(N1
), Prefix
(N2
));
10594 -- All other cases, not clearly the same object
10605 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
10610 elsif not Is_Constrained
(T1
)
10611 and then not Is_Constrained
(T2
)
10612 and then Base_Type
(T1
) = Base_Type
(T2
)
10616 -- For now don't bother with case of identical constraints, to be
10617 -- fiddled with later on perhaps (this is only used for optimization
10618 -- purposes, so it is not critical to do a best possible job)
10629 function Same_Value
(Node1
, Node2
: Node_Id
) return Boolean is
10631 if Compile_Time_Known_Value
(Node1
)
10632 and then Compile_Time_Known_Value
(Node2
)
10633 and then Expr_Value
(Node1
) = Expr_Value
(Node2
)
10636 elsif Same_Object
(Node1
, Node2
) then
10647 procedure Save_Actual
(N
: Node_Id
; Writable
: Boolean := False) is
10649 if Is_Entity_Name
(N
)
10651 Nkind_In
(N
, N_Indexed_Component
, N_Selected_Component
, N_Slice
)
10653 (Nkind
(N
) = N_Attribute_Reference
10654 and then Attribute_Name
(N
) = Name_Access
)
10657 -- We are only interested in IN OUT parameters of inner calls
10660 or else Nkind
(Parent
(N
)) = N_Function_Call
10661 or else Nkind
(Parent
(N
)) in N_Op
10663 Actuals_In_Call
.Increment_Last
;
10664 Actuals_In_Call
.Table
(Actuals_In_Call
.Last
) := (N
, Writable
);
10669 ------------------------
10670 -- Scope_Is_Transient --
10671 ------------------------
10673 function Scope_Is_Transient
return Boolean is
10675 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
10676 end Scope_Is_Transient
;
10682 function Scope_Within
(Scope1
, Scope2
: Entity_Id
) return Boolean is
10687 while Scop
/= Standard_Standard
loop
10688 Scop
:= Scope
(Scop
);
10690 if Scop
= Scope2
then
10698 --------------------------
10699 -- Scope_Within_Or_Same --
10700 --------------------------
10702 function Scope_Within_Or_Same
(Scope1
, Scope2
: Entity_Id
) return Boolean is
10707 while Scop
/= Standard_Standard
loop
10708 if Scop
= Scope2
then
10711 Scop
:= Scope
(Scop
);
10716 end Scope_Within_Or_Same
;
10718 --------------------
10719 -- Set_Convention --
10720 --------------------
10722 procedure Set_Convention
(E
: Entity_Id
; Val
: Snames
.Convention_Id
) is
10724 Basic_Set_Convention
(E
, Val
);
10727 and then Is_Access_Subprogram_Type
(Base_Type
(E
))
10728 and then Has_Foreign_Convention
(E
)
10730 Set_Can_Use_Internal_Rep
(E
, False);
10732 end Set_Convention
;
10734 ------------------------
10735 -- Set_Current_Entity --
10736 ------------------------
10738 -- The given entity is to be set as the currently visible definition
10739 -- of its associated name (i.e. the Node_Id associated with its name).
10740 -- All we have to do is to get the name from the identifier, and
10741 -- then set the associated Node_Id to point to the given entity.
10743 procedure Set_Current_Entity
(E
: Entity_Id
) is
10745 Set_Name_Entity_Id
(Chars
(E
), E
);
10746 end Set_Current_Entity
;
10748 ---------------------------
10749 -- Set_Debug_Info_Needed --
10750 ---------------------------
10752 procedure Set_Debug_Info_Needed
(T
: Entity_Id
) is
10754 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
);
10755 pragma Inline
(Set_Debug_Info_Needed_If_Not_Set
);
10756 -- Used to set debug info in a related node if not set already
10758 --------------------------------------
10759 -- Set_Debug_Info_Needed_If_Not_Set --
10760 --------------------------------------
10762 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
) is
10765 and then not Needs_Debug_Info
(E
)
10767 Set_Debug_Info_Needed
(E
);
10769 -- For a private type, indicate that the full view also needs
10770 -- debug information.
10773 and then Is_Private_Type
(E
)
10774 and then Present
(Full_View
(E
))
10776 Set_Debug_Info_Needed
(Full_View
(E
));
10779 end Set_Debug_Info_Needed_If_Not_Set
;
10781 -- Start of processing for Set_Debug_Info_Needed
10784 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which
10785 -- indicates that Debug_Info_Needed is never required for the entity.
10788 or else Debug_Info_Off
(T
)
10793 -- Set flag in entity itself. Note that we will go through the following
10794 -- circuitry even if the flag is already set on T. That's intentional,
10795 -- it makes sure that the flag will be set in subsidiary entities.
10797 Set_Needs_Debug_Info
(T
);
10799 -- Set flag on subsidiary entities if not set already
10801 if Is_Object
(T
) then
10802 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
10804 elsif Is_Type
(T
) then
10805 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
10807 if Is_Record_Type
(T
) then
10809 Ent
: Entity_Id
:= First_Entity
(T
);
10811 while Present
(Ent
) loop
10812 Set_Debug_Info_Needed_If_Not_Set
(Ent
);
10817 -- For a class wide subtype, we also need debug information
10818 -- for the equivalent type.
10820 if Ekind
(T
) = E_Class_Wide_Subtype
then
10821 Set_Debug_Info_Needed_If_Not_Set
(Equivalent_Type
(T
));
10824 elsif Is_Array_Type
(T
) then
10825 Set_Debug_Info_Needed_If_Not_Set
(Component_Type
(T
));
10828 Indx
: Node_Id
:= First_Index
(T
);
10830 while Present
(Indx
) loop
10831 Set_Debug_Info_Needed_If_Not_Set
(Etype
(Indx
));
10832 Indx
:= Next_Index
(Indx
);
10836 if Is_Packed
(T
) then
10837 Set_Debug_Info_Needed_If_Not_Set
(Packed_Array_Type
(T
));
10840 elsif Is_Access_Type
(T
) then
10841 Set_Debug_Info_Needed_If_Not_Set
(Directly_Designated_Type
(T
));
10843 elsif Is_Private_Type
(T
) then
10844 Set_Debug_Info_Needed_If_Not_Set
(Full_View
(T
));
10846 elsif Is_Protected_Type
(T
) then
10847 Set_Debug_Info_Needed_If_Not_Set
(Corresponding_Record_Type
(T
));
10850 end Set_Debug_Info_Needed
;
10852 ---------------------------------
10853 -- Set_Entity_With_Style_Check --
10854 ---------------------------------
10856 procedure Set_Entity_With_Style_Check
(N
: Node_Id
; Val
: Entity_Id
) is
10857 Val_Actual
: Entity_Id
;
10861 Set_Entity
(N
, Val
);
10864 and then not Suppress_Style_Checks
(Val
)
10865 and then not In_Instance
10867 if Nkind
(N
) = N_Identifier
then
10869 elsif Nkind
(N
) = N_Expanded_Name
then
10870 Nod
:= Selector_Name
(N
);
10875 -- A special situation arises for derived operations, where we want
10876 -- to do the check against the parent (since the Sloc of the derived
10877 -- operation points to the derived type declaration itself).
10880 while not Comes_From_Source
(Val_Actual
)
10881 and then Nkind
(Val_Actual
) in N_Entity
10882 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
10883 or else Is_Subprogram
(Val_Actual
)
10884 or else Is_Generic_Subprogram
(Val_Actual
))
10885 and then Present
(Alias
(Val_Actual
))
10887 Val_Actual
:= Alias
(Val_Actual
);
10890 -- Renaming declarations for generic actuals do not come from source,
10891 -- and have a different name from that of the entity they rename, so
10892 -- there is no style check to perform here.
10894 if Chars
(Nod
) = Chars
(Val_Actual
) then
10895 Style
.Check_Identifier
(Nod
, Val_Actual
);
10899 Set_Entity
(N
, Val
);
10900 end Set_Entity_With_Style_Check
;
10902 ------------------------
10903 -- Set_Name_Entity_Id --
10904 ------------------------
10906 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
10908 Set_Name_Table_Info
(Id
, Int
(Val
));
10909 end Set_Name_Entity_Id
;
10911 ---------------------
10912 -- Set_Next_Actual --
10913 ---------------------
10915 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
10917 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
10918 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
10920 end Set_Next_Actual
;
10922 ----------------------------------
10923 -- Set_Optimize_Alignment_Flags --
10924 ----------------------------------
10926 procedure Set_Optimize_Alignment_Flags
(E
: Entity_Id
) is
10928 if Optimize_Alignment
= 'S' then
10929 Set_Optimize_Alignment_Space
(E
);
10930 elsif Optimize_Alignment
= 'T' then
10931 Set_Optimize_Alignment_Time
(E
);
10933 end Set_Optimize_Alignment_Flags
;
10935 -----------------------
10936 -- Set_Public_Status --
10937 -----------------------
10939 procedure Set_Public_Status
(Id
: Entity_Id
) is
10940 S
: constant Entity_Id
:= Current_Scope
;
10942 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean;
10943 -- Determines if E is defined within handled statement sequence or
10944 -- an if statement, returns True if so, False otherwise.
10946 ----------------------
10947 -- Within_HSS_Or_If --
10948 ----------------------
10950 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean is
10953 N
:= Declaration_Node
(E
);
10960 elsif Nkind_In
(N
, N_Handled_Sequence_Of_Statements
,
10966 end Within_HSS_Or_If
;
10968 -- Start of processing for Set_Public_Status
10971 -- Everything in the scope of Standard is public
10973 if S
= Standard_Standard
then
10974 Set_Is_Public
(Id
);
10976 -- Entity is definitely not public if enclosing scope is not public
10978 elsif not Is_Public
(S
) then
10981 -- An object or function declaration that occurs in a handled sequence
10982 -- of statements or within an if statement is the declaration for a
10983 -- temporary object or local subprogram generated by the expander. It
10984 -- never needs to be made public and furthermore, making it public can
10985 -- cause back end problems.
10987 elsif Nkind_In
(Parent
(Id
), N_Object_Declaration
,
10988 N_Function_Specification
)
10989 and then Within_HSS_Or_If
(Id
)
10993 -- Entities in public packages or records are public
10995 elsif Ekind
(S
) = E_Package
or Is_Record_Type
(S
) then
10996 Set_Is_Public
(Id
);
10998 -- The bounds of an entry family declaration can generate object
10999 -- declarations that are visible to the back-end, e.g. in the
11000 -- the declaration of a composite type that contains tasks.
11002 elsif Is_Concurrent_Type
(S
)
11003 and then not Has_Completion
(S
)
11004 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
11006 Set_Is_Public
(Id
);
11008 end Set_Public_Status
;
11010 -----------------------------
11011 -- Set_Referenced_Modified --
11012 -----------------------------
11014 procedure Set_Referenced_Modified
(N
: Node_Id
; Out_Param
: Boolean) is
11018 -- Deal with indexed or selected component where prefix is modified
11020 if Nkind_In
(N
, N_Indexed_Component
, N_Selected_Component
) then
11021 Pref
:= Prefix
(N
);
11023 -- If prefix is access type, then it is the designated object that is
11024 -- being modified, which means we have no entity to set the flag on.
11026 if No
(Etype
(Pref
)) or else Is_Access_Type
(Etype
(Pref
)) then
11029 -- Otherwise chase the prefix
11032 Set_Referenced_Modified
(Pref
, Out_Param
);
11035 -- Otherwise see if we have an entity name (only other case to process)
11037 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
11038 Set_Referenced_As_LHS
(Entity
(N
), not Out_Param
);
11039 Set_Referenced_As_Out_Parameter
(Entity
(N
), Out_Param
);
11041 end Set_Referenced_Modified
;
11043 ----------------------------
11044 -- Set_Scope_Is_Transient --
11045 ----------------------------
11047 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
11049 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
11050 end Set_Scope_Is_Transient
;
11052 -------------------
11053 -- Set_Size_Info --
11054 -------------------
11056 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
11058 -- We copy Esize, but not RM_Size, since in general RM_Size is
11059 -- subtype specific and does not get inherited by all subtypes.
11061 Set_Esize
(T1
, Esize
(T2
));
11062 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
11064 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
11066 Is_Discrete_Or_Fixed_Point_Type
(T2
)
11068 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
11071 Set_Alignment
(T1
, Alignment
(T2
));
11074 --------------------
11075 -- Static_Integer --
11076 --------------------
11078 function Static_Integer
(N
: Node_Id
) return Uint
is
11080 Analyze_And_Resolve
(N
, Any_Integer
);
11083 or else Error_Posted
(N
)
11084 or else Etype
(N
) = Any_Type
11089 if Is_Static_Expression
(N
) then
11090 if not Raises_Constraint_Error
(N
) then
11091 return Expr_Value
(N
);
11096 elsif Etype
(N
) = Any_Type
then
11100 Flag_Non_Static_Expr
11101 ("static integer expression required here", N
);
11104 end Static_Integer
;
11106 --------------------------
11107 -- Statically_Different --
11108 --------------------------
11110 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
11111 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
11112 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
11114 return Is_Entity_Name
(R1
)
11115 and then Is_Entity_Name
(R2
)
11116 and then Entity
(R1
) /= Entity
(R2
)
11117 and then not Is_Formal
(Entity
(R1
))
11118 and then not Is_Formal
(Entity
(R2
));
11119 end Statically_Different
;
11121 -----------------------------
11122 -- Subprogram_Access_Level --
11123 -----------------------------
11125 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
11127 if Present
(Alias
(Subp
)) then
11128 return Subprogram_Access_Level
(Alias
(Subp
));
11130 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
11132 end Subprogram_Access_Level
;
11138 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
11140 if Debug_Flag_W
then
11141 for J
in 0 .. Scope_Stack
.Last
loop
11146 Write_Name
(Chars
(E
));
11147 Write_Str
(" from ");
11148 Write_Location
(Sloc
(N
));
11153 -----------------------
11154 -- Transfer_Entities --
11155 -----------------------
11157 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
11158 Ent
: Entity_Id
:= First_Entity
(From
);
11165 if (Last_Entity
(To
)) = Empty
then
11166 Set_First_Entity
(To
, Ent
);
11168 Set_Next_Entity
(Last_Entity
(To
), Ent
);
11171 Set_Last_Entity
(To
, Last_Entity
(From
));
11173 while Present
(Ent
) loop
11174 Set_Scope
(Ent
, To
);
11176 if not Is_Public
(Ent
) then
11177 Set_Public_Status
(Ent
);
11180 and then Ekind
(Ent
) = E_Record_Subtype
11183 -- The components of the propagated Itype must be public
11189 Comp
:= First_Entity
(Ent
);
11190 while Present
(Comp
) loop
11191 Set_Is_Public
(Comp
);
11192 Next_Entity
(Comp
);
11201 Set_First_Entity
(From
, Empty
);
11202 Set_Last_Entity
(From
, Empty
);
11203 end Transfer_Entities
;
11205 -----------------------
11206 -- Type_Access_Level --
11207 -----------------------
11209 function Type_Access_Level
(Typ
: Entity_Id
) return Uint
is
11213 Btyp
:= Base_Type
(Typ
);
11215 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
11216 -- simply use the level where the type is declared. This is true for
11217 -- stand-alone object declarations, and for anonymous access types
11218 -- associated with components the level is the same as that of the
11219 -- enclosing composite type. However, special treatment is needed for
11220 -- the cases of access parameters, return objects of an anonymous access
11221 -- type, and, in Ada 95, access discriminants of limited types.
11223 if Ekind
(Btyp
) in Access_Kind
then
11224 if Ekind
(Btyp
) = E_Anonymous_Access_Type
then
11226 -- If the type is a nonlocal anonymous access type (such as for
11227 -- an access parameter) we treat it as being declared at the
11228 -- library level to ensure that names such as X.all'access don't
11229 -- fail static accessibility checks.
11231 if not Is_Local_Anonymous_Access
(Typ
) then
11232 return Scope_Depth
(Standard_Standard
);
11234 -- If this is a return object, the accessibility level is that of
11235 -- the result subtype of the enclosing function. The test here is
11236 -- little complicated, because we have to account for extended
11237 -- return statements that have been rewritten as blocks, in which
11238 -- case we have to find and the Is_Return_Object attribute of the
11239 -- itype's associated object. It would be nice to find a way to
11240 -- simplify this test, but it doesn't seem worthwhile to add a new
11241 -- flag just for purposes of this test. ???
11243 elsif Ekind
(Scope
(Btyp
)) = E_Return_Statement
11246 and then Nkind
(Associated_Node_For_Itype
(Btyp
)) =
11247 N_Object_Declaration
11248 and then Is_Return_Object
11249 (Defining_Identifier
11250 (Associated_Node_For_Itype
(Btyp
))))
11256 Scop
:= Scope
(Scope
(Btyp
));
11257 while Present
(Scop
) loop
11258 exit when Ekind
(Scop
) = E_Function
;
11259 Scop
:= Scope
(Scop
);
11262 -- Treat the return object's type as having the level of the
11263 -- function's result subtype (as per RM05-6.5(5.3/2)).
11265 return Type_Access_Level
(Etype
(Scop
));
11270 Btyp
:= Root_Type
(Btyp
);
11272 -- The accessibility level of anonymous access types associated with
11273 -- discriminants is that of the current instance of the type, and
11274 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
11276 -- AI-402: access discriminants have accessibility based on the
11277 -- object rather than the type in Ada 2005, so the above paragraph
11280 -- ??? Needs completion with rules from AI-416
11282 if Ada_Version
<= Ada_95
11283 and then Ekind
(Typ
) = E_Anonymous_Access_Type
11284 and then Present
(Associated_Node_For_Itype
(Typ
))
11285 and then Nkind
(Associated_Node_For_Itype
(Typ
)) =
11286 N_Discriminant_Specification
11288 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
)) + 1;
11292 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
11293 end Type_Access_Level
;
11295 --------------------------
11296 -- Unit_Declaration_Node --
11297 --------------------------
11299 function Unit_Declaration_Node
(Unit_Id
: Entity_Id
) return Node_Id
is
11300 N
: Node_Id
:= Parent
(Unit_Id
);
11303 -- Predefined operators do not have a full function declaration
11305 if Ekind
(Unit_Id
) = E_Operator
then
11309 -- Isn't there some better way to express the following ???
11311 while Nkind
(N
) /= N_Abstract_Subprogram_Declaration
11312 and then Nkind
(N
) /= N_Formal_Package_Declaration
11313 and then Nkind
(N
) /= N_Function_Instantiation
11314 and then Nkind
(N
) /= N_Generic_Package_Declaration
11315 and then Nkind
(N
) /= N_Generic_Subprogram_Declaration
11316 and then Nkind
(N
) /= N_Package_Declaration
11317 and then Nkind
(N
) /= N_Package_Body
11318 and then Nkind
(N
) /= N_Package_Instantiation
11319 and then Nkind
(N
) /= N_Package_Renaming_Declaration
11320 and then Nkind
(N
) /= N_Procedure_Instantiation
11321 and then Nkind
(N
) /= N_Protected_Body
11322 and then Nkind
(N
) /= N_Subprogram_Declaration
11323 and then Nkind
(N
) /= N_Subprogram_Body
11324 and then Nkind
(N
) /= N_Subprogram_Body_Stub
11325 and then Nkind
(N
) /= N_Subprogram_Renaming_Declaration
11326 and then Nkind
(N
) /= N_Task_Body
11327 and then Nkind
(N
) /= N_Task_Type_Declaration
11328 and then Nkind
(N
) not in N_Formal_Subprogram_Declaration
11329 and then Nkind
(N
) not in N_Generic_Renaming_Declaration
11332 pragma Assert
(Present
(N
));
11336 end Unit_Declaration_Node
;
11338 ------------------------------
11339 -- Universal_Interpretation --
11340 ------------------------------
11342 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
11343 Index
: Interp_Index
;
11347 -- The argument may be a formal parameter of an operator or subprogram
11348 -- with multiple interpretations, or else an expression for an actual.
11350 if Nkind
(Opnd
) = N_Defining_Identifier
11351 or else not Is_Overloaded
(Opnd
)
11353 if Etype
(Opnd
) = Universal_Integer
11354 or else Etype
(Opnd
) = Universal_Real
11356 return Etype
(Opnd
);
11362 Get_First_Interp
(Opnd
, Index
, It
);
11363 while Present
(It
.Typ
) loop
11364 if It
.Typ
= Universal_Integer
11365 or else It
.Typ
= Universal_Real
11370 Get_Next_Interp
(Index
, It
);
11375 end Universal_Interpretation
;
11381 function Unqualify
(Expr
: Node_Id
) return Node_Id
is
11383 -- Recurse to handle unlikely case of multiple levels of qualification
11385 if Nkind
(Expr
) = N_Qualified_Expression
then
11386 return Unqualify
(Expression
(Expr
));
11388 -- Normal case, not a qualified expression
11395 ----------------------
11396 -- Within_Init_Proc --
11397 ----------------------
11399 function Within_Init_Proc
return Boolean is
11403 S
:= Current_Scope
;
11404 while not Is_Overloadable
(S
) loop
11405 if S
= Standard_Standard
then
11412 return Is_Init_Proc
(S
);
11413 end Within_Init_Proc
;
11419 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
11420 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
11421 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
11423 function Has_One_Matching_Field
return Boolean;
11424 -- Determines if Expec_Type is a record type with a single component or
11425 -- discriminant whose type matches the found type or is one dimensional
11426 -- array whose component type matches the found type.
11428 ----------------------------
11429 -- Has_One_Matching_Field --
11430 ----------------------------
11432 function Has_One_Matching_Field
return Boolean is
11436 if Is_Array_Type
(Expec_Type
)
11437 and then Number_Dimensions
(Expec_Type
) = 1
11439 Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
11443 elsif not Is_Record_Type
(Expec_Type
) then
11447 E
:= First_Entity
(Expec_Type
);
11452 elsif (Ekind
(E
) /= E_Discriminant
11453 and then Ekind
(E
) /= E_Component
)
11454 or else (Chars
(E
) = Name_uTag
11455 or else Chars
(E
) = Name_uParent
)
11464 if not Covers
(Etype
(E
), Found_Type
) then
11467 elsif Present
(Next_Entity
(E
)) then
11474 end Has_One_Matching_Field
;
11476 -- Start of processing for Wrong_Type
11479 -- Don't output message if either type is Any_Type, or if a message
11480 -- has already been posted for this node. We need to do the latter
11481 -- check explicitly (it is ordinarily done in Errout), because we
11482 -- are using ! to force the output of the error messages.
11484 if Expec_Type
= Any_Type
11485 or else Found_Type
= Any_Type
11486 or else Error_Posted
(Expr
)
11490 -- In an instance, there is an ongoing problem with completion of
11491 -- type derived from private types. Their structure is what Gigi
11492 -- expects, but the Etype is the parent type rather than the
11493 -- derived private type itself. Do not flag error in this case. The
11494 -- private completion is an entity without a parent, like an Itype.
11495 -- Similarly, full and partial views may be incorrect in the instance.
11496 -- There is no simple way to insure that it is consistent ???
11498 elsif In_Instance
then
11499 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
11501 (Has_Private_Declaration
(Expected_Type
)
11502 or else Has_Private_Declaration
(Etype
(Expr
)))
11503 and then No
(Parent
(Expected_Type
))
11509 -- An interesting special check. If the expression is parenthesized
11510 -- and its type corresponds to the type of the sole component of the
11511 -- expected record type, or to the component type of the expected one
11512 -- dimensional array type, then assume we have a bad aggregate attempt.
11514 if Nkind
(Expr
) in N_Subexpr
11515 and then Paren_Count
(Expr
) /= 0
11516 and then Has_One_Matching_Field
11518 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
11520 -- Another special check, if we are looking for a pool-specific access
11521 -- type and we found an E_Access_Attribute_Type, then we have the case
11522 -- of an Access attribute being used in a context which needs a pool-
11523 -- specific type, which is never allowed. The one extra check we make
11524 -- is that the expected designated type covers the Found_Type.
11526 elsif Is_Access_Type
(Expec_Type
)
11527 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
11528 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
11529 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
11531 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
11533 Error_Msg_N
-- CODEFIX
11534 ("result must be general access type!", Expr
);
11535 Error_Msg_NE
-- CODEFIX
11536 ("add ALL to }!", Expr
, Expec_Type
);
11538 -- Another special check, if the expected type is an integer type,
11539 -- but the expression is of type System.Address, and the parent is
11540 -- an addition or subtraction operation whose left operand is the
11541 -- expression in question and whose right operand is of an integral
11542 -- type, then this is an attempt at address arithmetic, so give
11543 -- appropriate message.
11545 elsif Is_Integer_Type
(Expec_Type
)
11546 and then Is_RTE
(Found_Type
, RE_Address
)
11547 and then (Nkind
(Parent
(Expr
)) = N_Op_Add
11549 Nkind
(Parent
(Expr
)) = N_Op_Subtract
)
11550 and then Expr
= Left_Opnd
(Parent
(Expr
))
11551 and then Is_Integer_Type
(Etype
(Right_Opnd
(Parent
(Expr
))))
11554 ("address arithmetic not predefined in package System",
11557 ("\possible missing with/use of System.Storage_Elements",
11561 -- If the expected type is an anonymous access type, as for access
11562 -- parameters and discriminants, the error is on the designated types.
11564 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
11565 if Comes_From_Source
(Expec_Type
) then
11566 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
11569 ("expected an access type with designated}",
11570 Expr
, Designated_Type
(Expec_Type
));
11573 if Is_Access_Type
(Found_Type
)
11574 and then not Comes_From_Source
(Found_Type
)
11577 ("\\found an access type with designated}!",
11578 Expr
, Designated_Type
(Found_Type
));
11580 if From_With_Type
(Found_Type
) then
11581 Error_Msg_NE
("\\found incomplete}!", Expr
, Found_Type
);
11582 Error_Msg_Qual_Level
:= 99;
11583 Error_Msg_NE
-- CODEFIX
11584 ("\\missing `WITH &;", Expr
, Scope
(Found_Type
));
11585 Error_Msg_Qual_Level
:= 0;
11587 Error_Msg_NE
("found}!", Expr
, Found_Type
);
11591 -- Normal case of one type found, some other type expected
11594 -- If the names of the two types are the same, see if some number
11595 -- of levels of qualification will help. Don't try more than three
11596 -- levels, and if we get to standard, it's no use (and probably
11597 -- represents an error in the compiler) Also do not bother with
11598 -- internal scope names.
11601 Expec_Scope
: Entity_Id
;
11602 Found_Scope
: Entity_Id
;
11605 Expec_Scope
:= Expec_Type
;
11606 Found_Scope
:= Found_Type
;
11608 for Levels
in Int
range 0 .. 3 loop
11609 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
11610 Error_Msg_Qual_Level
:= Levels
;
11614 Expec_Scope
:= Scope
(Expec_Scope
);
11615 Found_Scope
:= Scope
(Found_Scope
);
11617 exit when Expec_Scope
= Standard_Standard
11618 or else Found_Scope
= Standard_Standard
11619 or else not Comes_From_Source
(Expec_Scope
)
11620 or else not Comes_From_Source
(Found_Scope
);
11624 if Is_Record_Type
(Expec_Type
)
11625 and then Present
(Corresponding_Remote_Type
(Expec_Type
))
11627 Error_Msg_NE
("expected}!", Expr
,
11628 Corresponding_Remote_Type
(Expec_Type
));
11630 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
11633 if Is_Entity_Name
(Expr
)
11634 and then Is_Package_Or_Generic_Package
(Entity
(Expr
))
11636 Error_Msg_N
("\\found package name!", Expr
);
11638 elsif Is_Entity_Name
(Expr
)
11640 (Ekind
(Entity
(Expr
)) = E_Procedure
11642 Ekind
(Entity
(Expr
)) = E_Generic_Procedure
)
11644 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
11646 ("found procedure name, possibly missing Access attribute!",
11650 ("\\found procedure name instead of function!", Expr
);
11653 elsif Nkind
(Expr
) = N_Function_Call
11654 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
11655 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
11656 and then No
(Parameter_Associations
(Expr
))
11659 ("found function name, possibly missing Access attribute!",
11662 -- Catch common error: a prefix or infix operator which is not
11663 -- directly visible because the type isn't.
11665 elsif Nkind
(Expr
) in N_Op
11666 and then Is_Overloaded
(Expr
)
11667 and then not Is_Immediately_Visible
(Expec_Type
)
11668 and then not Is_Potentially_Use_Visible
(Expec_Type
)
11669 and then not In_Use
(Expec_Type
)
11670 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
11673 ("operator of the type is not directly visible!", Expr
);
11675 elsif Ekind
(Found_Type
) = E_Void
11676 and then Present
(Parent
(Found_Type
))
11677 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
11679 Error_Msg_NE
("\\found premature usage of}!", Expr
, Found_Type
);
11682 Error_Msg_NE
("\\found}!", Expr
, Found_Type
);
11685 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
11686 -- of the same modular type, and (M1 and M2) = 0 was intended.
11688 if Expec_Type
= Standard_Boolean
11689 and then Is_Modular_Integer_Type
(Found_Type
)
11690 and then Nkind_In
(Parent
(Expr
), N_Op_And
, N_Op_Or
, N_Op_Xor
)
11691 and then Nkind
(Right_Opnd
(Parent
(Expr
))) in N_Op_Compare
11694 Op
: constant Node_Id
:= Right_Opnd
(Parent
(Expr
));
11695 L
: constant Node_Id
:= Left_Opnd
(Op
);
11696 R
: constant Node_Id
:= Right_Opnd
(Op
);
11698 -- The case for the message is when the left operand of the
11699 -- comparison is the same modular type, or when it is an
11700 -- integer literal (or other universal integer expression),
11701 -- which would have been typed as the modular type if the
11702 -- parens had been there.
11704 if (Etype
(L
) = Found_Type
11706 Etype
(L
) = Universal_Integer
)
11707 and then Is_Integer_Type
(Etype
(R
))
11710 ("\\possible missing parens for modular operation", Expr
);
11715 -- Reset error message qualification indication
11717 Error_Msg_Qual_Level
:= 0;