1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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 Restrict; use Restrict;
44 with Rident; use Rident;
45 with Rtsfind; use Rtsfind;
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_Threshold : 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 threshold 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.
106 -- The actuals to be checked in a call to Check_Order_Dependence are at
107 -- positions 1 .. Last.
109 type Actual_Name is record
111 Is_Writable : Boolean;
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 procedure Mark_Non_ALFA_Subprogram_Body_Unconditional;
145 -- Perform the action for Mark_Non_ALFA_Subprogram_Body, which allows the
146 -- latter to be small and inlined.
148 ------------------------------
149 -- Abstract_Interface_List --
150 ------------------------------
152 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
156 if Is_Concurrent_Type (Typ) then
158 -- If we are dealing with a synchronized subtype, go to the base
159 -- type, whose declaration has the interface list.
161 -- Shouldn't this be Declaration_Node???
163 Nod := Parent (Base_Type (Typ));
165 if Nkind (Nod) = N_Full_Type_Declaration then
169 elsif Ekind (Typ) = E_Record_Type_With_Private then
170 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
171 Nod := Type_Definition (Parent (Typ));
173 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
174 if Present (Full_View (Typ))
175 and then Nkind (Parent (Full_View (Typ)))
176 = N_Full_Type_Declaration
178 Nod := Type_Definition (Parent (Full_View (Typ)));
180 -- If the full-view is not available we cannot do anything else
181 -- here (the source has errors).
187 -- Support for generic formals with interfaces is still missing ???
189 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
194 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
198 elsif Ekind (Typ) = E_Record_Subtype then
199 Nod := Type_Definition (Parent (Etype (Typ)));
201 elsif Ekind (Typ) = E_Record_Subtype_With_Private then
203 -- Recurse, because parent may still be a private extension. Also
204 -- note that the full view of the subtype or the full view of its
205 -- base type may (both) be unavailable.
207 return Abstract_Interface_List (Etype (Typ));
209 else pragma Assert ((Ekind (Typ)) = E_Record_Type);
210 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
211 Nod := Formal_Type_Definition (Parent (Typ));
213 Nod := Type_Definition (Parent (Typ));
217 return Interface_List (Nod);
218 end Abstract_Interface_List;
220 --------------------------------
221 -- Add_Access_Type_To_Process --
222 --------------------------------
224 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
228 Ensure_Freeze_Node (E);
229 L := Access_Types_To_Process (Freeze_Node (E));
233 Set_Access_Types_To_Process (Freeze_Node (E), L);
237 end Add_Access_Type_To_Process;
239 ----------------------------
240 -- Add_Global_Declaration --
241 ----------------------------
243 procedure Add_Global_Declaration (N : Node_Id) is
244 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
247 if No (Declarations (Aux_Node)) then
248 Set_Declarations (Aux_Node, New_List);
251 Append_To (Declarations (Aux_Node), N);
253 end Add_Global_Declaration;
259 -- For now, just 8/16/32/64. but analyze later if AAMP is special???
261 function Addressable (V : Uint) return Boolean is
263 return V = Uint_8 or else
269 function Addressable (V : Int) return Boolean is
277 -----------------------
278 -- Alignment_In_Bits --
279 -----------------------
281 function Alignment_In_Bits (E : Entity_Id) return Uint is
283 return Alignment (E) * System_Storage_Unit;
284 end Alignment_In_Bits;
286 -----------------------------------------
287 -- Apply_Compile_Time_Constraint_Error --
288 -----------------------------------------
290 procedure Apply_Compile_Time_Constraint_Error
293 Reason : RT_Exception_Code;
294 Ent : Entity_Id := Empty;
295 Typ : Entity_Id := Empty;
296 Loc : Source_Ptr := No_Location;
297 Rep : Boolean := True;
298 Warn : Boolean := False)
300 Stat : constant Boolean := Is_Static_Expression (N);
301 R_Stat : constant Node_Id :=
302 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
313 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
319 -- Now we replace the node by an N_Raise_Constraint_Error node
320 -- This does not need reanalyzing, so set it as analyzed now.
323 Set_Analyzed (N, True);
326 Set_Raises_Constraint_Error (N);
328 -- Now deal with possible local raise handling
330 Possible_Local_Raise (N, Standard_Constraint_Error);
332 -- If the original expression was marked as static, the result is
333 -- still marked as static, but the Raises_Constraint_Error flag is
334 -- always set so that further static evaluation is not attempted.
337 Set_Is_Static_Expression (N);
339 end Apply_Compile_Time_Constraint_Error;
341 --------------------------------
342 -- Bad_Predicated_Subtype_Use --
343 --------------------------------
345 procedure Bad_Predicated_Subtype_Use
351 if Has_Predicates (Typ) then
352 if Is_Generic_Actual_Type (Typ) then
353 Error_Msg_FE (Msg & '?', N, Typ);
354 Error_Msg_F ("\Program_Error will be raised at run time?", N);
356 Make_Raise_Program_Error (Sloc (N),
357 Reason => PE_Bad_Predicated_Generic_Type));
360 Error_Msg_FE (Msg, N, Typ);
363 end Bad_Predicated_Subtype_Use;
365 --------------------------
366 -- Build_Actual_Subtype --
367 --------------------------
369 function Build_Actual_Subtype
371 N : Node_Or_Entity_Id) return Node_Id
374 -- Normally Sloc (N), but may point to corresponding body in some cases
376 Constraints : List_Id;
382 Disc_Type : Entity_Id;
388 if Nkind (N) = N_Defining_Identifier then
389 Obj := New_Reference_To (N, Loc);
391 -- If this is a formal parameter of a subprogram declaration, and
392 -- we are compiling the body, we want the declaration for the
393 -- actual subtype to carry the source position of the body, to
394 -- prevent anomalies in gdb when stepping through the code.
396 if Is_Formal (N) then
398 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
400 if Nkind (Decl) = N_Subprogram_Declaration
401 and then Present (Corresponding_Body (Decl))
403 Loc := Sloc (Corresponding_Body (Decl));
412 if Is_Array_Type (T) then
413 Constraints := New_List;
414 for J in 1 .. Number_Dimensions (T) loop
416 -- Build an array subtype declaration with the nominal subtype and
417 -- the bounds of the actual. Add the declaration in front of the
418 -- local declarations for the subprogram, for analysis before any
419 -- reference to the formal in the body.
422 Make_Attribute_Reference (Loc,
424 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
425 Attribute_Name => Name_First,
426 Expressions => New_List (
427 Make_Integer_Literal (Loc, J)));
430 Make_Attribute_Reference (Loc,
432 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
433 Attribute_Name => Name_Last,
434 Expressions => New_List (
435 Make_Integer_Literal (Loc, J)));
437 Append (Make_Range (Loc, Lo, Hi), Constraints);
440 -- If the type has unknown discriminants there is no constrained
441 -- subtype to build. This is never called for a formal or for a
442 -- lhs, so returning the type is ok ???
444 elsif Has_Unknown_Discriminants (T) then
448 Constraints := New_List;
450 -- Type T is a generic derived type, inherit the discriminants from
453 if Is_Private_Type (T)
454 and then No (Full_View (T))
456 -- T was flagged as an error if it was declared as a formal
457 -- derived type with known discriminants. In this case there
458 -- is no need to look at the parent type since T already carries
459 -- its own discriminants.
461 and then not Error_Posted (T)
463 Disc_Type := Etype (Base_Type (T));
468 Discr := First_Discriminant (Disc_Type);
469 while Present (Discr) loop
470 Append_To (Constraints,
471 Make_Selected_Component (Loc,
473 Duplicate_Subexpr_No_Checks (Obj),
474 Selector_Name => New_Occurrence_Of (Discr, Loc)));
475 Next_Discriminant (Discr);
479 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
480 Set_Is_Internal (Subt);
483 Make_Subtype_Declaration (Loc,
484 Defining_Identifier => Subt,
485 Subtype_Indication =>
486 Make_Subtype_Indication (Loc,
487 Subtype_Mark => New_Reference_To (T, Loc),
489 Make_Index_Or_Discriminant_Constraint (Loc,
490 Constraints => Constraints)));
492 Mark_Rewrite_Insertion (Decl);
494 end Build_Actual_Subtype;
496 ---------------------------------------
497 -- Build_Actual_Subtype_Of_Component --
498 ---------------------------------------
500 function Build_Actual_Subtype_Of_Component
502 N : Node_Id) return Node_Id
504 Loc : constant Source_Ptr := Sloc (N);
505 P : constant Node_Id := Prefix (N);
508 Indx_Type : Entity_Id;
510 Deaccessed_T : Entity_Id;
511 -- This is either a copy of T, or if T is an access type, then it is
512 -- the directly designated type of this access type.
514 function Build_Actual_Array_Constraint return List_Id;
515 -- If one or more of the bounds of the component depends on
516 -- discriminants, build actual constraint using the discriminants
519 function Build_Actual_Record_Constraint return List_Id;
520 -- Similar to previous one, for discriminated components constrained
521 -- by the discriminant of the enclosing object.
523 -----------------------------------
524 -- Build_Actual_Array_Constraint --
525 -----------------------------------
527 function Build_Actual_Array_Constraint return List_Id is
528 Constraints : constant List_Id := New_List;
536 Indx := First_Index (Deaccessed_T);
537 while Present (Indx) loop
538 Old_Lo := Type_Low_Bound (Etype (Indx));
539 Old_Hi := Type_High_Bound (Etype (Indx));
541 if Denotes_Discriminant (Old_Lo) then
543 Make_Selected_Component (Loc,
544 Prefix => New_Copy_Tree (P),
545 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
548 Lo := New_Copy_Tree (Old_Lo);
550 -- The new bound will be reanalyzed in the enclosing
551 -- declaration. For literal bounds that come from a type
552 -- declaration, the type of the context must be imposed, so
553 -- insure that analysis will take place. For non-universal
554 -- types this is not strictly necessary.
556 Set_Analyzed (Lo, False);
559 if Denotes_Discriminant (Old_Hi) then
561 Make_Selected_Component (Loc,
562 Prefix => New_Copy_Tree (P),
563 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
566 Hi := New_Copy_Tree (Old_Hi);
567 Set_Analyzed (Hi, False);
570 Append (Make_Range (Loc, Lo, Hi), Constraints);
575 end Build_Actual_Array_Constraint;
577 ------------------------------------
578 -- Build_Actual_Record_Constraint --
579 ------------------------------------
581 function Build_Actual_Record_Constraint return List_Id is
582 Constraints : constant List_Id := New_List;
587 D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
588 while Present (D) loop
589 if Denotes_Discriminant (Node (D)) then
590 D_Val := Make_Selected_Component (Loc,
591 Prefix => New_Copy_Tree (P),
592 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
595 D_Val := New_Copy_Tree (Node (D));
598 Append (D_Val, Constraints);
603 end Build_Actual_Record_Constraint;
605 -- Start of processing for Build_Actual_Subtype_Of_Component
608 -- Why the test for Spec_Expression mode here???
610 if In_Spec_Expression then
613 -- More comments for the rest of this body would be good ???
615 elsif Nkind (N) = N_Explicit_Dereference then
616 if Is_Composite_Type (T)
617 and then not Is_Constrained (T)
618 and then not (Is_Class_Wide_Type (T)
619 and then Is_Constrained (Root_Type (T)))
620 and then not Has_Unknown_Discriminants (T)
622 -- If the type of the dereference is already constrained, it is an
625 if Is_Array_Type (Etype (N))
626 and then Is_Constrained (Etype (N))
630 Remove_Side_Effects (P);
631 return Build_Actual_Subtype (T, N);
638 if Ekind (T) = E_Access_Subtype then
639 Deaccessed_T := Designated_Type (T);
644 if Ekind (Deaccessed_T) = E_Array_Subtype then
645 Id := First_Index (Deaccessed_T);
646 while Present (Id) loop
647 Indx_Type := Underlying_Type (Etype (Id));
649 if Denotes_Discriminant (Type_Low_Bound (Indx_Type))
651 Denotes_Discriminant (Type_High_Bound (Indx_Type))
653 Remove_Side_Effects (P);
655 Build_Component_Subtype
656 (Build_Actual_Array_Constraint, Loc, Base_Type (T));
662 elsif Is_Composite_Type (Deaccessed_T)
663 and then Has_Discriminants (Deaccessed_T)
664 and then not Has_Unknown_Discriminants (Deaccessed_T)
666 D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
667 while Present (D) loop
668 if Denotes_Discriminant (Node (D)) then
669 Remove_Side_Effects (P);
671 Build_Component_Subtype (
672 Build_Actual_Record_Constraint, Loc, Base_Type (T));
679 -- If none of the above, the actual and nominal subtypes are the same
682 end Build_Actual_Subtype_Of_Component;
684 -----------------------------
685 -- Build_Component_Subtype --
686 -----------------------------
688 function Build_Component_Subtype
691 T : Entity_Id) return Node_Id
697 -- Unchecked_Union components do not require component subtypes
699 if Is_Unchecked_Union (T) then
703 Subt := Make_Temporary (Loc, 'S');
704 Set_Is_Internal (Subt);
707 Make_Subtype_Declaration (Loc,
708 Defining_Identifier => Subt,
709 Subtype_Indication =>
710 Make_Subtype_Indication (Loc,
711 Subtype_Mark => New_Reference_To (Base_Type (T), Loc),
713 Make_Index_Or_Discriminant_Constraint (Loc,
716 Mark_Rewrite_Insertion (Decl);
718 end Build_Component_Subtype;
720 ---------------------------
721 -- Build_Default_Subtype --
722 ---------------------------
724 function Build_Default_Subtype
726 N : Node_Id) return Entity_Id
728 Loc : constant Source_Ptr := Sloc (N);
732 if not Has_Discriminants (T) or else Is_Constrained (T) then
736 Disc := First_Discriminant (T);
738 if No (Discriminant_Default_Value (Disc)) then
743 Act : constant Entity_Id := Make_Temporary (Loc, 'S');
744 Constraints : constant List_Id := New_List;
748 while Present (Disc) loop
749 Append_To (Constraints,
750 New_Copy_Tree (Discriminant_Default_Value (Disc)));
751 Next_Discriminant (Disc);
755 Make_Subtype_Declaration (Loc,
756 Defining_Identifier => Act,
757 Subtype_Indication =>
758 Make_Subtype_Indication (Loc,
759 Subtype_Mark => New_Occurrence_Of (T, Loc),
761 Make_Index_Or_Discriminant_Constraint (Loc,
762 Constraints => Constraints)));
764 Insert_Action (N, Decl);
768 end Build_Default_Subtype;
770 --------------------------------------------
771 -- Build_Discriminal_Subtype_Of_Component --
772 --------------------------------------------
774 function Build_Discriminal_Subtype_Of_Component
775 (T : Entity_Id) return Node_Id
777 Loc : constant Source_Ptr := Sloc (T);
781 function Build_Discriminal_Array_Constraint return List_Id;
782 -- If one or more of the bounds of the component depends on
783 -- discriminants, build actual constraint using the discriminants
786 function Build_Discriminal_Record_Constraint return List_Id;
787 -- Similar to previous one, for discriminated components constrained
788 -- by the discriminant of the enclosing object.
790 ----------------------------------------
791 -- Build_Discriminal_Array_Constraint --
792 ----------------------------------------
794 function Build_Discriminal_Array_Constraint return List_Id is
795 Constraints : constant List_Id := New_List;
803 Indx := First_Index (T);
804 while Present (Indx) loop
805 Old_Lo := Type_Low_Bound (Etype (Indx));
806 Old_Hi := Type_High_Bound (Etype (Indx));
808 if Denotes_Discriminant (Old_Lo) then
809 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
812 Lo := New_Copy_Tree (Old_Lo);
815 if Denotes_Discriminant (Old_Hi) then
816 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
819 Hi := New_Copy_Tree (Old_Hi);
822 Append (Make_Range (Loc, Lo, Hi), Constraints);
827 end Build_Discriminal_Array_Constraint;
829 -----------------------------------------
830 -- Build_Discriminal_Record_Constraint --
831 -----------------------------------------
833 function Build_Discriminal_Record_Constraint return List_Id is
834 Constraints : constant List_Id := New_List;
839 D := First_Elmt (Discriminant_Constraint (T));
840 while Present (D) loop
841 if Denotes_Discriminant (Node (D)) then
843 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
846 D_Val := New_Copy_Tree (Node (D));
849 Append (D_Val, Constraints);
854 end Build_Discriminal_Record_Constraint;
856 -- Start of processing for Build_Discriminal_Subtype_Of_Component
859 if Ekind (T) = E_Array_Subtype then
860 Id := First_Index (T);
861 while Present (Id) loop
862 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else
863 Denotes_Discriminant (Type_High_Bound (Etype (Id)))
865 return Build_Component_Subtype
866 (Build_Discriminal_Array_Constraint, Loc, T);
872 elsif Ekind (T) = E_Record_Subtype
873 and then Has_Discriminants (T)
874 and then not Has_Unknown_Discriminants (T)
876 D := First_Elmt (Discriminant_Constraint (T));
877 while Present (D) loop
878 if Denotes_Discriminant (Node (D)) then
879 return Build_Component_Subtype
880 (Build_Discriminal_Record_Constraint, Loc, T);
887 -- If none of the above, the actual and nominal subtypes are the same
890 end Build_Discriminal_Subtype_Of_Component;
892 ------------------------------
893 -- Build_Elaboration_Entity --
894 ------------------------------
896 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
897 Loc : constant Source_Ptr := Sloc (N);
899 Elab_Ent : Entity_Id;
901 procedure Set_Package_Name (Ent : Entity_Id);
902 -- Given an entity, sets the fully qualified name of the entity in
903 -- Name_Buffer, with components separated by double underscores. This
904 -- is a recursive routine that climbs the scope chain to Standard.
906 ----------------------
907 -- Set_Package_Name --
908 ----------------------
910 procedure Set_Package_Name (Ent : Entity_Id) is
912 if Scope (Ent) /= Standard_Standard then
913 Set_Package_Name (Scope (Ent));
916 Nam : constant String := Get_Name_String (Chars (Ent));
918 Name_Buffer (Name_Len + 1) := '_';
919 Name_Buffer (Name_Len + 2) := '_';
920 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
921 Name_Len := Name_Len + Nam'Length + 2;
925 Get_Name_String (Chars (Ent));
927 end Set_Package_Name;
929 -- Start of processing for Build_Elaboration_Entity
932 -- Ignore if already constructed
934 if Present (Elaboration_Entity (Spec_Id)) then
938 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
939 -- name with dots replaced by double underscore. We have to manually
940 -- construct this name, since it will be elaborated in the outer scope,
941 -- and thus will not have the unit name automatically prepended.
943 Set_Package_Name (Spec_Id);
947 Name_Buffer (Name_Len + 1) := '_';
948 Name_Buffer (Name_Len + 2) := 'E';
949 Name_Len := Name_Len + 2;
951 -- Create elaboration flag
954 Make_Defining_Identifier (Loc, Chars => Name_Find);
955 Set_Elaboration_Entity (Spec_Id, Elab_Ent);
958 Make_Object_Declaration (Loc,
959 Defining_Identifier => Elab_Ent,
961 New_Occurrence_Of (Standard_Boolean, Loc),
963 New_Occurrence_Of (Standard_False, Loc));
965 Push_Scope (Standard_Standard);
966 Add_Global_Declaration (Decl);
969 -- Reset True_Constant indication, since we will indeed assign a value
970 -- to the variable in the binder main. We also kill the Current_Value
971 -- and Last_Assignment fields for the same reason.
973 Set_Is_True_Constant (Elab_Ent, False);
974 Set_Current_Value (Elab_Ent, Empty);
975 Set_Last_Assignment (Elab_Ent, Empty);
977 -- We do not want any further qualification of the name (if we did
978 -- not do this, we would pick up the name of the generic package
979 -- in the case of a library level generic instantiation).
981 Set_Has_Qualified_Name (Elab_Ent);
982 Set_Has_Fully_Qualified_Name (Elab_Ent);
983 end Build_Elaboration_Entity;
985 -----------------------------------
986 -- Cannot_Raise_Constraint_Error --
987 -----------------------------------
989 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
991 if Compile_Time_Known_Value (Expr) then
994 elsif Do_Range_Check (Expr) then
997 elsif Raises_Constraint_Error (Expr) then
1001 case Nkind (Expr) is
1002 when N_Identifier =>
1005 when N_Expanded_Name =>
1008 when N_Selected_Component =>
1009 return not Do_Discriminant_Check (Expr);
1011 when N_Attribute_Reference =>
1012 if Do_Overflow_Check (Expr) then
1015 elsif No (Expressions (Expr)) then
1023 N := First (Expressions (Expr));
1024 while Present (N) loop
1025 if Cannot_Raise_Constraint_Error (N) then
1036 when N_Type_Conversion =>
1037 if Do_Overflow_Check (Expr)
1038 or else Do_Length_Check (Expr)
1039 or else Do_Tag_Check (Expr)
1044 Cannot_Raise_Constraint_Error (Expression (Expr));
1047 when N_Unchecked_Type_Conversion =>
1048 return Cannot_Raise_Constraint_Error (Expression (Expr));
1051 if Do_Overflow_Check (Expr) then
1055 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1062 if Do_Division_Check (Expr)
1063 or else Do_Overflow_Check (Expr)
1068 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1070 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1089 N_Op_Shift_Right_Arithmetic |
1093 if Do_Overflow_Check (Expr) then
1097 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1099 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1106 end Cannot_Raise_Constraint_Error;
1108 ---------------------------------------
1109 -- Check_Later_Vs_Basic_Declarations --
1110 ---------------------------------------
1112 procedure Check_Later_Vs_Basic_Declarations
1114 During_Parsing : Boolean)
1116 Body_Sloc : Source_Ptr;
1119 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
1120 -- Return whether Decl is considered as a declarative item.
1121 -- When During_Parsing is True, the semantics of Ada 83 is followed.
1122 -- When During_Parsing is False, the semantics of SPARK is followed.
1124 -------------------------------
1125 -- Is_Later_Declarative_Item --
1126 -------------------------------
1128 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
1130 if Nkind (Decl) in N_Later_Decl_Item then
1133 elsif Nkind (Decl) = N_Pragma then
1136 elsif During_Parsing then
1139 -- In SPARK, a package declaration is not considered as a later
1140 -- declarative item.
1142 elsif Nkind (Decl) = N_Package_Declaration then
1145 -- In SPARK, a renaming is considered as a later declarative item
1147 elsif Nkind (Decl) in N_Renaming_Declaration then
1153 end Is_Later_Declarative_Item;
1155 -- Start of Check_Later_Vs_Basic_Declarations
1158 Decl := First (Decls);
1160 -- Loop through sequence of basic declarative items
1162 Outer : while Present (Decl) loop
1163 if Nkind (Decl) /= N_Subprogram_Body
1164 and then Nkind (Decl) /= N_Package_Body
1165 and then Nkind (Decl) /= N_Task_Body
1166 and then Nkind (Decl) not in N_Body_Stub
1170 -- Once a body is encountered, we only allow later declarative
1171 -- items. The inner loop checks the rest of the list.
1174 Body_Sloc := Sloc (Decl);
1176 Inner : while Present (Decl) loop
1177 if not Is_Later_Declarative_Item (Decl) then
1178 if During_Parsing then
1179 if Ada_Version = Ada_83 then
1180 Error_Msg_Sloc := Body_Sloc;
1182 ("(Ada 83) decl cannot appear after body#", Decl);
1185 Error_Msg_Sloc := Body_Sloc;
1186 Check_SPARK_Restriction
1187 ("decl cannot appear after body#", Decl);
1195 end Check_Later_Vs_Basic_Declarations;
1197 -----------------------------------------
1198 -- Check_Dynamically_Tagged_Expression --
1199 -----------------------------------------
1201 procedure Check_Dynamically_Tagged_Expression
1204 Related_Nod : Node_Id)
1207 pragma Assert (Is_Tagged_Type (Typ));
1209 -- In order to avoid spurious errors when analyzing the expanded code,
1210 -- this check is done only for nodes that come from source and for
1211 -- actuals of generic instantiations.
1213 if (Comes_From_Source (Related_Nod)
1214 or else In_Generic_Actual (Expr))
1215 and then (Is_Class_Wide_Type (Etype (Expr))
1216 or else Is_Dynamically_Tagged (Expr))
1217 and then Is_Tagged_Type (Typ)
1218 and then not Is_Class_Wide_Type (Typ)
1220 Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
1222 end Check_Dynamically_Tagged_Expression;
1224 --------------------------
1225 -- Check_Fully_Declared --
1226 --------------------------
1228 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
1230 if Ekind (T) = E_Incomplete_Type then
1232 -- Ada 2005 (AI-50217): If the type is available through a limited
1233 -- with_clause, verify that its full view has been analyzed.
1235 if From_With_Type (T)
1236 and then Present (Non_Limited_View (T))
1237 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
1239 -- The non-limited view is fully declared
1244 ("premature usage of incomplete}", N, First_Subtype (T));
1247 -- Need comments for these tests ???
1249 elsif Has_Private_Component (T)
1250 and then not Is_Generic_Type (Root_Type (T))
1251 and then not In_Spec_Expression
1253 -- Special case: if T is the anonymous type created for a single
1254 -- task or protected object, use the name of the source object.
1256 if Is_Concurrent_Type (T)
1257 and then not Comes_From_Source (T)
1258 and then Nkind (N) = N_Object_Declaration
1260 Error_Msg_NE ("type of& has incomplete component", N,
1261 Defining_Identifier (N));
1265 ("premature usage of incomplete}", N, First_Subtype (T));
1268 end Check_Fully_Declared;
1270 -------------------------
1271 -- Check_Nested_Access --
1272 -------------------------
1274 procedure Check_Nested_Access (Ent : Entity_Id) is
1275 Scop : constant Entity_Id := Current_Scope;
1276 Current_Subp : Entity_Id;
1277 Enclosing : Entity_Id;
1280 -- Currently only enabled for VM back-ends for efficiency, should we
1281 -- enable it more systematically ???
1283 -- Check for Is_Imported needs commenting below ???
1285 if VM_Target /= No_VM
1286 and then (Ekind (Ent) = E_Variable
1288 Ekind (Ent) = E_Constant
1290 Ekind (Ent) = E_Loop_Parameter)
1291 and then Scope (Ent) /= Empty
1292 and then not Is_Library_Level_Entity (Ent)
1293 and then not Is_Imported (Ent)
1295 if Is_Subprogram (Scop)
1296 or else Is_Generic_Subprogram (Scop)
1297 or else Is_Entry (Scop)
1299 Current_Subp := Scop;
1301 Current_Subp := Current_Subprogram;
1304 Enclosing := Enclosing_Subprogram (Ent);
1306 if Enclosing /= Empty
1307 and then Enclosing /= Current_Subp
1309 Set_Has_Up_Level_Access (Ent, True);
1312 end Check_Nested_Access;
1314 ----------------------------
1315 -- Check_Order_Dependence --
1316 ----------------------------
1318 procedure Check_Order_Dependence is
1323 if Ada_Version < Ada_2012 then
1327 -- Ada 2012 AI04-0144-2: Dangerous order dependence. Actuals in nested
1328 -- calls within a construct have been collected. If one of them is
1329 -- writable and overlaps with another one, evaluation of the enclosing
1330 -- construct is nondeterministic. This is illegal in Ada 2012, but is
1331 -- treated as a warning for now.
1333 for J in 1 .. Actuals_In_Call.Last loop
1334 if Actuals_In_Call.Table (J).Is_Writable then
1335 Act1 := Actuals_In_Call.Table (J).Act;
1337 if Nkind (Act1) = N_Attribute_Reference then
1338 Act1 := Prefix (Act1);
1341 for K in 1 .. Actuals_In_Call.Last loop
1343 Act2 := Actuals_In_Call.Table (K).Act;
1345 if Nkind (Act2) = N_Attribute_Reference then
1346 Act2 := Prefix (Act2);
1349 if Actuals_In_Call.Table (K).Is_Writable
1356 elsif Denotes_Same_Object (Act1, Act2)
1357 and then Parent (Act1) /= Parent (Act2)
1360 ("result may differ if evaluated "
1361 & "after other actual in expression?", Act1);
1368 -- Remove checked actuals from table
1370 Actuals_In_Call.Set_Last (0);
1371 end Check_Order_Dependence;
1373 ------------------------------------------
1374 -- Check_Potentially_Blocking_Operation --
1375 ------------------------------------------
1377 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
1381 -- N is one of the potentially blocking operations listed in 9.5.1(8).
1382 -- When pragma Detect_Blocking is active, the run time will raise
1383 -- Program_Error. Here we only issue a warning, since we generally
1384 -- support the use of potentially blocking operations in the absence
1387 -- Indirect blocking through a subprogram call cannot be diagnosed
1388 -- statically without interprocedural analysis, so we do not attempt
1391 S := Scope (Current_Scope);
1392 while Present (S) and then S /= Standard_Standard loop
1393 if Is_Protected_Type (S) then
1395 ("potentially blocking operation in protected operation?", N);
1401 end Check_Potentially_Blocking_Operation;
1403 ------------------------------
1404 -- Check_Unprotected_Access --
1405 ------------------------------
1407 procedure Check_Unprotected_Access
1411 Cont_Encl_Typ : Entity_Id;
1412 Pref_Encl_Typ : Entity_Id;
1414 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
1415 -- Check whether Obj is a private component of a protected object.
1416 -- Return the protected type where the component resides, Empty
1419 function Is_Public_Operation return Boolean;
1420 -- Verify that the enclosing operation is callable from outside the
1421 -- protected object, to minimize false positives.
1423 ------------------------------
1424 -- Enclosing_Protected_Type --
1425 ------------------------------
1427 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
1429 if Is_Entity_Name (Obj) then
1431 Ent : Entity_Id := Entity (Obj);
1434 -- The object can be a renaming of a private component, use
1435 -- the original record component.
1437 if Is_Prival (Ent) then
1438 Ent := Prival_Link (Ent);
1441 if Is_Protected_Type (Scope (Ent)) then
1447 -- For indexed and selected components, recursively check the prefix
1449 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
1450 return Enclosing_Protected_Type (Prefix (Obj));
1452 -- The object does not denote a protected component
1457 end Enclosing_Protected_Type;
1459 -------------------------
1460 -- Is_Public_Operation --
1461 -------------------------
1463 function Is_Public_Operation return Boolean is
1470 and then S /= Pref_Encl_Typ
1472 if Scope (S) = Pref_Encl_Typ then
1473 E := First_Entity (Pref_Encl_Typ);
1475 and then E /= First_Private_Entity (Pref_Encl_Typ)
1488 end Is_Public_Operation;
1490 -- Start of processing for Check_Unprotected_Access
1493 if Nkind (Expr) = N_Attribute_Reference
1494 and then Attribute_Name (Expr) = Name_Unchecked_Access
1496 Cont_Encl_Typ := Enclosing_Protected_Type (Context);
1497 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
1499 -- Check whether we are trying to export a protected component to a
1500 -- context with an equal or lower access level.
1502 if Present (Pref_Encl_Typ)
1503 and then No (Cont_Encl_Typ)
1504 and then Is_Public_Operation
1505 and then Scope_Depth (Pref_Encl_Typ) >=
1506 Object_Access_Level (Context)
1509 ("?possible unprotected access to protected data", Expr);
1512 end Check_Unprotected_Access;
1518 procedure Check_VMS (Construct : Node_Id) is
1520 if not OpenVMS_On_Target then
1522 ("this construct is allowed only in Open'V'M'S", Construct);
1526 ------------------------
1527 -- Collect_Interfaces --
1528 ------------------------
1530 procedure Collect_Interfaces
1532 Ifaces_List : out Elist_Id;
1533 Exclude_Parents : Boolean := False;
1534 Use_Full_View : Boolean := True)
1536 procedure Collect (Typ : Entity_Id);
1537 -- Subsidiary subprogram used to traverse the whole list
1538 -- of directly and indirectly implemented interfaces
1544 procedure Collect (Typ : Entity_Id) is
1545 Ancestor : Entity_Id;
1553 -- Handle private types
1556 and then Is_Private_Type (Typ)
1557 and then Present (Full_View (Typ))
1559 Full_T := Full_View (Typ);
1562 -- Include the ancestor if we are generating the whole list of
1563 -- abstract interfaces.
1565 if Etype (Full_T) /= Typ
1567 -- Protect the frontend against wrong sources. For example:
1570 -- type A is tagged null record;
1571 -- type B is new A with private;
1572 -- type C is new A with private;
1574 -- type B is new C with null record;
1575 -- type C is new B with null record;
1578 and then Etype (Full_T) /= T
1580 Ancestor := Etype (Full_T);
1583 if Is_Interface (Ancestor)
1584 and then not Exclude_Parents
1586 Append_Unique_Elmt (Ancestor, Ifaces_List);
1590 -- Traverse the graph of ancestor interfaces
1592 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
1593 Id := First (Abstract_Interface_List (Full_T));
1594 while Present (Id) loop
1595 Iface := Etype (Id);
1597 -- Protect against wrong uses. For example:
1598 -- type I is interface;
1599 -- type O is tagged null record;
1600 -- type Wrong is new I and O with null record; -- ERROR
1602 if Is_Interface (Iface) then
1604 and then Etype (T) /= T
1605 and then Interface_Present_In_Ancestor (Etype (T), Iface)
1610 Append_Unique_Elmt (Iface, Ifaces_List);
1619 -- Start of processing for Collect_Interfaces
1622 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
1623 Ifaces_List := New_Elmt_List;
1625 end Collect_Interfaces;
1627 ----------------------------------
1628 -- Collect_Interface_Components --
1629 ----------------------------------
1631 procedure Collect_Interface_Components
1632 (Tagged_Type : Entity_Id;
1633 Components_List : out Elist_Id)
1635 procedure Collect (Typ : Entity_Id);
1636 -- Subsidiary subprogram used to climb to the parents
1642 procedure Collect (Typ : Entity_Id) is
1643 Tag_Comp : Entity_Id;
1644 Parent_Typ : Entity_Id;
1647 -- Handle private types
1649 if Present (Full_View (Etype (Typ))) then
1650 Parent_Typ := Full_View (Etype (Typ));
1652 Parent_Typ := Etype (Typ);
1655 if Parent_Typ /= Typ
1657 -- Protect the frontend against wrong sources. For example:
1660 -- type A is tagged null record;
1661 -- type B is new A with private;
1662 -- type C is new A with private;
1664 -- type B is new C with null record;
1665 -- type C is new B with null record;
1668 and then Parent_Typ /= Tagged_Type
1670 Collect (Parent_Typ);
1673 -- Collect the components containing tags of secondary dispatch
1676 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
1677 while Present (Tag_Comp) loop
1678 pragma Assert (Present (Related_Type (Tag_Comp)));
1679 Append_Elmt (Tag_Comp, Components_List);
1681 Tag_Comp := Next_Tag_Component (Tag_Comp);
1685 -- Start of processing for Collect_Interface_Components
1688 pragma Assert (Ekind (Tagged_Type) = E_Record_Type
1689 and then Is_Tagged_Type (Tagged_Type));
1691 Components_List := New_Elmt_List;
1692 Collect (Tagged_Type);
1693 end Collect_Interface_Components;
1695 -----------------------------
1696 -- Collect_Interfaces_Info --
1697 -----------------------------
1699 procedure Collect_Interfaces_Info
1701 Ifaces_List : out Elist_Id;
1702 Components_List : out Elist_Id;
1703 Tags_List : out Elist_Id)
1705 Comps_List : Elist_Id;
1706 Comp_Elmt : Elmt_Id;
1707 Comp_Iface : Entity_Id;
1708 Iface_Elmt : Elmt_Id;
1711 function Search_Tag (Iface : Entity_Id) return Entity_Id;
1712 -- Search for the secondary tag associated with the interface type
1713 -- Iface that is implemented by T.
1719 function Search_Tag (Iface : Entity_Id) return Entity_Id is
1722 if not Is_CPP_Class (T) then
1723 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
1725 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
1729 and then Is_Tag (Node (ADT))
1730 and then Related_Type (Node (ADT)) /= Iface
1732 -- Skip secondary dispatch table referencing thunks to user
1733 -- defined primitives covered by this interface.
1735 pragma Assert (Has_Suffix (Node (ADT), 'P'));
1738 -- Skip secondary dispatch tables of Ada types
1740 if not Is_CPP_Class (T) then
1742 -- Skip secondary dispatch table referencing thunks to
1743 -- predefined primitives.
1745 pragma Assert (Has_Suffix (Node (ADT), 'Y'));
1748 -- Skip secondary dispatch table referencing user-defined
1749 -- primitives covered by this interface.
1751 pragma Assert (Has_Suffix (Node (ADT), 'D'));
1754 -- Skip secondary dispatch table referencing predefined
1757 pragma Assert (Has_Suffix (Node (ADT), 'Z'));
1762 pragma Assert (Is_Tag (Node (ADT)));
1766 -- Start of processing for Collect_Interfaces_Info
1769 Collect_Interfaces (T, Ifaces_List);
1770 Collect_Interface_Components (T, Comps_List);
1772 -- Search for the record component and tag associated with each
1773 -- interface type of T.
1775 Components_List := New_Elmt_List;
1776 Tags_List := New_Elmt_List;
1778 Iface_Elmt := First_Elmt (Ifaces_List);
1779 while Present (Iface_Elmt) loop
1780 Iface := Node (Iface_Elmt);
1782 -- Associate the primary tag component and the primary dispatch table
1783 -- with all the interfaces that are parents of T
1785 if Is_Ancestor (Iface, T, Use_Full_View => True) then
1786 Append_Elmt (First_Tag_Component (T), Components_List);
1787 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
1789 -- Otherwise search for the tag component and secondary dispatch
1793 Comp_Elmt := First_Elmt (Comps_List);
1794 while Present (Comp_Elmt) loop
1795 Comp_Iface := Related_Type (Node (Comp_Elmt));
1797 if Comp_Iface = Iface
1798 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
1800 Append_Elmt (Node (Comp_Elmt), Components_List);
1801 Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
1805 Next_Elmt (Comp_Elmt);
1807 pragma Assert (Present (Comp_Elmt));
1810 Next_Elmt (Iface_Elmt);
1812 end Collect_Interfaces_Info;
1814 ---------------------
1815 -- Collect_Parents --
1816 ---------------------
1818 procedure Collect_Parents
1820 List : out Elist_Id;
1821 Use_Full_View : Boolean := True)
1823 Current_Typ : Entity_Id := T;
1824 Parent_Typ : Entity_Id;
1827 List := New_Elmt_List;
1829 -- No action if the if the type has no parents
1831 if T = Etype (T) then
1836 Parent_Typ := Etype (Current_Typ);
1838 if Is_Private_Type (Parent_Typ)
1839 and then Present (Full_View (Parent_Typ))
1840 and then Use_Full_View
1842 Parent_Typ := Full_View (Base_Type (Parent_Typ));
1845 Append_Elmt (Parent_Typ, List);
1847 exit when Parent_Typ = Current_Typ;
1848 Current_Typ := Parent_Typ;
1850 end Collect_Parents;
1852 ----------------------------------
1853 -- Collect_Primitive_Operations --
1854 ----------------------------------
1856 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
1857 B_Type : constant Entity_Id := Base_Type (T);
1858 B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
1859 B_Scope : Entity_Id := Scope (B_Type);
1863 Formal_Derived : Boolean := False;
1866 function Match (E : Entity_Id) return Boolean;
1867 -- True if E's base type is B_Type, or E is of an anonymous access type
1868 -- and the base type of its designated type is B_Type.
1874 function Match (E : Entity_Id) return Boolean is
1875 Etyp : Entity_Id := Etype (E);
1878 if Ekind (Etyp) = E_Anonymous_Access_Type then
1879 Etyp := Designated_Type (Etyp);
1882 return Base_Type (Etyp) = B_Type;
1885 -- Start of processing for Collect_Primitive_Operations
1888 -- For tagged types, the primitive operations are collected as they
1889 -- are declared, and held in an explicit list which is simply returned.
1891 if Is_Tagged_Type (B_Type) then
1892 return Primitive_Operations (B_Type);
1894 -- An untagged generic type that is a derived type inherits the
1895 -- primitive operations of its parent type. Other formal types only
1896 -- have predefined operators, which are not explicitly represented.
1898 elsif Is_Generic_Type (B_Type) then
1899 if Nkind (B_Decl) = N_Formal_Type_Declaration
1900 and then Nkind (Formal_Type_Definition (B_Decl))
1901 = N_Formal_Derived_Type_Definition
1903 Formal_Derived := True;
1905 return New_Elmt_List;
1909 Op_List := New_Elmt_List;
1911 if B_Scope = Standard_Standard then
1912 if B_Type = Standard_String then
1913 Append_Elmt (Standard_Op_Concat, Op_List);
1915 elsif B_Type = Standard_Wide_String then
1916 Append_Elmt (Standard_Op_Concatw, Op_List);
1922 elsif (Is_Package_Or_Generic_Package (B_Scope)
1924 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
1926 or else Is_Derived_Type (B_Type)
1928 -- The primitive operations appear after the base type, except
1929 -- if the derivation happens within the private part of B_Scope
1930 -- and the type is a private type, in which case both the type
1931 -- and some primitive operations may appear before the base
1932 -- type, and the list of candidates starts after the type.
1934 if In_Open_Scopes (B_Scope)
1935 and then Scope (T) = B_Scope
1936 and then In_Private_Part (B_Scope)
1938 Id := Next_Entity (T);
1940 Id := Next_Entity (B_Type);
1943 while Present (Id) loop
1945 -- Note that generic formal subprograms are not
1946 -- considered to be primitive operations and thus
1947 -- are never inherited.
1949 if Is_Overloadable (Id)
1950 and then Nkind (Parent (Parent (Id)))
1951 not in N_Formal_Subprogram_Declaration
1959 Formal := First_Formal (Id);
1960 while Present (Formal) loop
1961 if Match (Formal) then
1966 Next_Formal (Formal);
1970 -- For a formal derived type, the only primitives are the
1971 -- ones inherited from the parent type. Operations appearing
1972 -- in the package declaration are not primitive for it.
1975 and then (not Formal_Derived
1976 or else Present (Alias (Id)))
1978 -- In the special case of an equality operator aliased to
1979 -- an overriding dispatching equality belonging to the same
1980 -- type, we don't include it in the list of primitives.
1981 -- This avoids inheriting multiple equality operators when
1982 -- deriving from untagged private types whose full type is
1983 -- tagged, which can otherwise cause ambiguities. Note that
1984 -- this should only happen for this kind of untagged parent
1985 -- type, since normally dispatching operations are inherited
1986 -- using the type's Primitive_Operations list.
1988 if Chars (Id) = Name_Op_Eq
1989 and then Is_Dispatching_Operation (Id)
1990 and then Present (Alias (Id))
1991 and then Present (Overridden_Operation (Alias (Id)))
1992 and then Base_Type (Etype (First_Entity (Id))) =
1993 Base_Type (Etype (First_Entity (Alias (Id))))
1997 -- Include the subprogram in the list of primitives
2000 Append_Elmt (Id, Op_List);
2007 -- For a type declared in System, some of its operations may
2008 -- appear in the target-specific extension to System.
2011 and then B_Scope = RTU_Entity (System)
2012 and then Present_System_Aux
2014 B_Scope := System_Aux_Id;
2015 Id := First_Entity (System_Aux_Id);
2021 end Collect_Primitive_Operations;
2023 -----------------------------------
2024 -- Compile_Time_Constraint_Error --
2025 -----------------------------------
2027 function Compile_Time_Constraint_Error
2030 Ent : Entity_Id := Empty;
2031 Loc : Source_Ptr := No_Location;
2032 Warn : Boolean := False) return Node_Id
2034 Msgc : String (1 .. Msg'Length + 2);
2035 -- Copy of message, with room for possible ? and ! at end
2045 -- A static constraint error in an instance body is not a fatal error.
2046 -- we choose to inhibit the message altogether, because there is no
2047 -- obvious node (for now) on which to post it. On the other hand the
2048 -- offending node must be replaced with a constraint_error in any case.
2050 -- No messages are generated if we already posted an error on this node
2052 if not Error_Posted (N) then
2053 if Loc /= No_Location then
2059 Msgc (1 .. Msg'Length) := Msg;
2062 -- Message is a warning, even in Ada 95 case
2064 if Msg (Msg'Last) = '?' then
2067 -- In Ada 83, all messages are warnings. In the private part and
2068 -- the body of an instance, constraint_checks are only warnings.
2069 -- We also make this a warning if the Warn parameter is set.
2072 or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
2078 elsif In_Instance_Not_Visible then
2083 -- Otherwise we have a real error message (Ada 95 static case)
2084 -- and we make this an unconditional message. Note that in the
2085 -- warning case we do not make the message unconditional, it seems
2086 -- quite reasonable to delete messages like this (about exceptions
2087 -- that will be raised) in dead code.
2095 -- Should we generate a warning? The answer is not quite yes. The
2096 -- very annoying exception occurs in the case of a short circuit
2097 -- operator where the left operand is static and decisive. Climb
2098 -- parents to see if that is the case we have here. Conditional
2099 -- expressions with decisive conditions are a similar situation.
2107 -- And then with False as left operand
2109 if Nkind (P) = N_And_Then
2110 and then Compile_Time_Known_Value (Left_Opnd (P))
2111 and then Is_False (Expr_Value (Left_Opnd (P)))
2116 -- OR ELSE with True as left operand
2118 elsif Nkind (P) = N_Or_Else
2119 and then Compile_Time_Known_Value (Left_Opnd (P))
2120 and then Is_True (Expr_Value (Left_Opnd (P)))
2125 -- Conditional expression
2127 elsif Nkind (P) = N_Conditional_Expression then
2129 Cond : constant Node_Id := First (Expressions (P));
2130 Texp : constant Node_Id := Next (Cond);
2131 Fexp : constant Node_Id := Next (Texp);
2134 if Compile_Time_Known_Value (Cond) then
2136 -- Condition is True and we are in the right operand
2138 if Is_True (Expr_Value (Cond))
2139 and then OldP = Fexp
2144 -- Condition is False and we are in the left operand
2146 elsif Is_False (Expr_Value (Cond))
2147 and then OldP = Texp
2155 -- Special case for component association in aggregates, where
2156 -- we want to keep climbing up to the parent aggregate.
2158 elsif Nkind (P) = N_Component_Association
2159 and then Nkind (Parent (P)) = N_Aggregate
2163 -- Keep going if within subexpression
2166 exit when Nkind (P) not in N_Subexpr;
2171 if Present (Ent) then
2172 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
2174 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
2178 if Inside_Init_Proc then
2180 ("\?& will be raised for objects of this type",
2181 N, Standard_Constraint_Error, Eloc);
2184 ("\?& will be raised at run time",
2185 N, Standard_Constraint_Error, Eloc);
2190 ("\static expression fails Constraint_Check", Eloc);
2191 Set_Error_Posted (N);
2197 end Compile_Time_Constraint_Error;
2199 -----------------------
2200 -- Conditional_Delay --
2201 -----------------------
2203 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
2205 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
2206 Set_Has_Delayed_Freeze (New_Ent);
2208 end Conditional_Delay;
2210 -------------------------
2211 -- Copy_Parameter_List --
2212 -------------------------
2214 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
2215 Loc : constant Source_Ptr := Sloc (Subp_Id);
2220 if No (First_Formal (Subp_Id)) then
2224 Formal := First_Formal (Subp_Id);
2225 while Present (Formal) loop
2227 (Make_Parameter_Specification (Loc,
2228 Defining_Identifier =>
2229 Make_Defining_Identifier (Sloc (Formal),
2230 Chars => Chars (Formal)),
2231 In_Present => In_Present (Parent (Formal)),
2232 Out_Present => Out_Present (Parent (Formal)),
2234 New_Reference_To (Etype (Formal), Loc),
2236 New_Copy_Tree (Expression (Parent (Formal)))),
2239 Next_Formal (Formal);
2244 end Copy_Parameter_List;
2246 --------------------
2247 -- Current_Entity --
2248 --------------------
2250 -- The currently visible definition for a given identifier is the
2251 -- one most chained at the start of the visibility chain, i.e. the
2252 -- one that is referenced by the Node_Id value of the name of the
2253 -- given identifier.
2255 function Current_Entity (N : Node_Id) return Entity_Id is
2257 return Get_Name_Entity_Id (Chars (N));
2260 -----------------------------
2261 -- Current_Entity_In_Scope --
2262 -----------------------------
2264 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
2266 CS : constant Entity_Id := Current_Scope;
2268 Transient_Case : constant Boolean := Scope_Is_Transient;
2271 E := Get_Name_Entity_Id (Chars (N));
2273 and then Scope (E) /= CS
2274 and then (not Transient_Case or else Scope (E) /= Scope (CS))
2280 end Current_Entity_In_Scope;
2286 function Current_Scope return Entity_Id is
2288 if Scope_Stack.Last = -1 then
2289 return Standard_Standard;
2292 C : constant Entity_Id :=
2293 Scope_Stack.Table (Scope_Stack.Last).Entity;
2298 return Standard_Standard;
2304 ------------------------
2305 -- Current_Subprogram --
2306 ------------------------
2308 function Current_Subprogram return Entity_Id is
2309 Scop : constant Entity_Id := Current_Scope;
2311 if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
2314 return Enclosing_Subprogram (Scop);
2316 end Current_Subprogram;
2318 -----------------------------------
2319 -- Mark_Non_ALFA_Subprogram_Body --
2320 -----------------------------------
2322 procedure Mark_Non_ALFA_Subprogram_Body is
2324 -- Isolate marking of the current subprogram body so that the body of
2325 -- Mark_Non_ALFA_Subprogram_Body is small and inlined.
2328 Mark_Non_ALFA_Subprogram_Body_Unconditional;
2330 end Mark_Non_ALFA_Subprogram_Body;
2332 -------------------------------------------------
2333 -- Mark_Non_ALFA_Subprogram_Body_Unconditional --
2334 -------------------------------------------------
2336 procedure Mark_Non_ALFA_Subprogram_Body_Unconditional is
2337 Cur_Subp : constant Entity_Id := Current_Subprogram;
2339 if Present (Cur_Subp)
2340 and then (Is_Subprogram (Cur_Subp)
2341 or else Is_Generic_Subprogram (Cur_Subp))
2343 Set_Body_Is_In_ALFA (Cur_Subp, False);
2345 end Mark_Non_ALFA_Subprogram_Body_Unconditional;
2347 ---------------------
2348 -- Defining_Entity --
2349 ---------------------
2351 function Defining_Entity (N : Node_Id) return Entity_Id is
2352 K : constant Node_Kind := Nkind (N);
2353 Err : Entity_Id := Empty;
2358 N_Subprogram_Declaration |
2359 N_Abstract_Subprogram_Declaration |
2361 N_Package_Declaration |
2362 N_Subprogram_Renaming_Declaration |
2363 N_Subprogram_Body_Stub |
2364 N_Generic_Subprogram_Declaration |
2365 N_Generic_Package_Declaration |
2366 N_Formal_Subprogram_Declaration
2368 return Defining_Entity (Specification (N));
2371 N_Component_Declaration |
2372 N_Defining_Program_Unit_Name |
2373 N_Discriminant_Specification |
2375 N_Entry_Declaration |
2376 N_Entry_Index_Specification |
2377 N_Exception_Declaration |
2378 N_Exception_Renaming_Declaration |
2379 N_Formal_Object_Declaration |
2380 N_Formal_Package_Declaration |
2381 N_Formal_Type_Declaration |
2382 N_Full_Type_Declaration |
2383 N_Implicit_Label_Declaration |
2384 N_Incomplete_Type_Declaration |
2385 N_Loop_Parameter_Specification |
2386 N_Number_Declaration |
2387 N_Object_Declaration |
2388 N_Object_Renaming_Declaration |
2389 N_Package_Body_Stub |
2390 N_Parameter_Specification |
2391 N_Private_Extension_Declaration |
2392 N_Private_Type_Declaration |
2394 N_Protected_Body_Stub |
2395 N_Protected_Type_Declaration |
2396 N_Single_Protected_Declaration |
2397 N_Single_Task_Declaration |
2398 N_Subtype_Declaration |
2401 N_Task_Type_Declaration
2403 return Defining_Identifier (N);
2406 return Defining_Entity (Proper_Body (N));
2409 N_Function_Instantiation |
2410 N_Function_Specification |
2411 N_Generic_Function_Renaming_Declaration |
2412 N_Generic_Package_Renaming_Declaration |
2413 N_Generic_Procedure_Renaming_Declaration |
2415 N_Package_Instantiation |
2416 N_Package_Renaming_Declaration |
2417 N_Package_Specification |
2418 N_Procedure_Instantiation |
2419 N_Procedure_Specification
2422 Nam : constant Node_Id := Defining_Unit_Name (N);
2425 if Nkind (Nam) in N_Entity then
2428 -- For Error, make up a name and attach to declaration
2429 -- so we can continue semantic analysis
2431 elsif Nam = Error then
2432 Err := Make_Temporary (Sloc (N), 'T');
2433 Set_Defining_Unit_Name (N, Err);
2436 -- If not an entity, get defining identifier
2439 return Defining_Identifier (Nam);
2443 when N_Block_Statement =>
2444 return Entity (Identifier (N));
2447 raise Program_Error;
2450 end Defining_Entity;
2452 --------------------------
2453 -- Denotes_Discriminant --
2454 --------------------------
2456 function Denotes_Discriminant
2458 Check_Concurrent : Boolean := False) return Boolean
2462 if not Is_Entity_Name (N)
2463 or else No (Entity (N))
2470 -- If we are checking for a protected type, the discriminant may have
2471 -- been rewritten as the corresponding discriminal of the original type
2472 -- or of the corresponding concurrent record, depending on whether we
2473 -- are in the spec or body of the protected type.
2475 return Ekind (E) = E_Discriminant
2478 and then Ekind (E) = E_In_Parameter
2479 and then Present (Discriminal_Link (E))
2481 (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
2483 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
2485 end Denotes_Discriminant;
2487 -------------------------
2488 -- Denotes_Same_Object --
2489 -------------------------
2491 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
2492 Obj1 : Node_Id := A1;
2493 Obj2 : Node_Id := A2;
2495 procedure Check_Renaming (Obj : in out Node_Id);
2496 -- If an object is a renaming, examine renamed object. If it is a
2497 -- dereference of a variable, or an indexed expression with non-constant
2498 -- indexes, no overlap check can be reported.
2500 --------------------
2501 -- Check_Renaming --
2502 --------------------
2504 procedure Check_Renaming (Obj : in out Node_Id) is
2506 if Is_Entity_Name (Obj)
2507 and then Present (Renamed_Entity (Entity (Obj)))
2509 Obj := Renamed_Entity (Entity (Obj));
2510 if Nkind (Obj) = N_Explicit_Dereference
2511 and then Is_Variable (Prefix (Obj))
2515 elsif Nkind (Obj) = N_Indexed_Component then
2520 Indx := First (Expressions (Obj));
2521 while Present (Indx) loop
2522 if not Is_OK_Static_Expression (Indx) then
2534 -- Start of processing for Denotes_Same_Object
2537 Check_Renaming (Obj1);
2538 Check_Renaming (Obj2);
2546 -- If we have entity names, then must be same entity
2548 if Is_Entity_Name (Obj1) then
2549 if Is_Entity_Name (Obj2) then
2550 return Entity (Obj1) = Entity (Obj2);
2555 -- No match if not same node kind
2557 elsif Nkind (Obj1) /= Nkind (Obj2) then
2560 -- For selected components, must have same prefix and selector
2562 elsif Nkind (Obj1) = N_Selected_Component then
2563 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
2565 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
2567 -- For explicit dereferences, prefixes must be same
2569 elsif Nkind (Obj1) = N_Explicit_Dereference then
2570 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
2572 -- For indexed components, prefixes and all subscripts must be the same
2574 elsif Nkind (Obj1) = N_Indexed_Component then
2575 if Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
2581 Indx1 := First (Expressions (Obj1));
2582 Indx2 := First (Expressions (Obj2));
2583 while Present (Indx1) loop
2585 -- Indexes must denote the same static value or same object
2587 if Is_OK_Static_Expression (Indx1) then
2588 if not Is_OK_Static_Expression (Indx2) then
2591 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
2595 elsif not Denotes_Same_Object (Indx1, Indx2) then
2609 -- For slices, prefixes must match and bounds must match
2611 elsif Nkind (Obj1) = N_Slice
2612 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
2615 Lo1, Lo2, Hi1, Hi2 : Node_Id;
2618 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
2619 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
2621 -- Check whether bounds are statically identical. There is no
2622 -- attempt to detect partial overlap of slices.
2624 return Denotes_Same_Object (Lo1, Lo2)
2625 and then Denotes_Same_Object (Hi1, Hi2);
2628 -- Literals will appear as indexes. Isn't this where we should check
2629 -- Known_At_Compile_Time at least if we are generating warnings ???
2631 elsif Nkind (Obj1) = N_Integer_Literal then
2632 return Intval (Obj1) = Intval (Obj2);
2637 end Denotes_Same_Object;
2639 -------------------------
2640 -- Denotes_Same_Prefix --
2641 -------------------------
2643 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
2646 if Is_Entity_Name (A1) then
2647 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
2648 and then not Is_Access_Type (Etype (A1))
2650 return Denotes_Same_Object (A1, Prefix (A2))
2651 or else Denotes_Same_Prefix (A1, Prefix (A2));
2656 elsif Is_Entity_Name (A2) then
2657 return Denotes_Same_Prefix (A2, A1);
2659 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
2661 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
2664 Root1, Root2 : Node_Id;
2665 Depth1, Depth2 : Int := 0;
2668 Root1 := Prefix (A1);
2669 while not Is_Entity_Name (Root1) loop
2671 (Root1, N_Selected_Component, N_Indexed_Component)
2675 Root1 := Prefix (Root1);
2678 Depth1 := Depth1 + 1;
2681 Root2 := Prefix (A2);
2682 while not Is_Entity_Name (Root2) loop
2684 (Root2, N_Selected_Component, N_Indexed_Component)
2688 Root2 := Prefix (Root2);
2691 Depth2 := Depth2 + 1;
2694 -- If both have the same depth and they do not denote the same
2695 -- object, they are disjoint and not warning is needed.
2697 if Depth1 = Depth2 then
2700 elsif Depth1 > Depth2 then
2701 Root1 := Prefix (A1);
2702 for I in 1 .. Depth1 - Depth2 - 1 loop
2703 Root1 := Prefix (Root1);
2706 return Denotes_Same_Object (Root1, A2);
2709 Root2 := Prefix (A2);
2710 for I in 1 .. Depth2 - Depth1 - 1 loop
2711 Root2 := Prefix (Root2);
2714 return Denotes_Same_Object (A1, Root2);
2721 end Denotes_Same_Prefix;
2723 ----------------------
2724 -- Denotes_Variable --
2725 ----------------------
2727 function Denotes_Variable (N : Node_Id) return Boolean is
2729 return Is_Variable (N) and then Paren_Count (N) = 0;
2730 end Denotes_Variable;
2732 -----------------------------
2733 -- Depends_On_Discriminant --
2734 -----------------------------
2736 function Depends_On_Discriminant (N : Node_Id) return Boolean is
2741 Get_Index_Bounds (N, L, H);
2742 return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
2743 end Depends_On_Discriminant;
2745 -------------------------
2746 -- Designate_Same_Unit --
2747 -------------------------
2749 function Designate_Same_Unit
2751 Name2 : Node_Id) return Boolean
2753 K1 : constant Node_Kind := Nkind (Name1);
2754 K2 : constant Node_Kind := Nkind (Name2);
2756 function Prefix_Node (N : Node_Id) return Node_Id;
2757 -- Returns the parent unit name node of a defining program unit name
2758 -- or the prefix if N is a selected component or an expanded name.
2760 function Select_Node (N : Node_Id) return Node_Id;
2761 -- Returns the defining identifier node of a defining program unit
2762 -- name or the selector node if N is a selected component or an
2769 function Prefix_Node (N : Node_Id) return Node_Id is
2771 if Nkind (N) = N_Defining_Program_Unit_Name then
2783 function Select_Node (N : Node_Id) return Node_Id is
2785 if Nkind (N) = N_Defining_Program_Unit_Name then
2786 return Defining_Identifier (N);
2789 return Selector_Name (N);
2793 -- Start of processing for Designate_Next_Unit
2796 if (K1 = N_Identifier or else
2797 K1 = N_Defining_Identifier)
2799 (K2 = N_Identifier or else
2800 K2 = N_Defining_Identifier)
2802 return Chars (Name1) = Chars (Name2);
2805 (K1 = N_Expanded_Name or else
2806 K1 = N_Selected_Component or else
2807 K1 = N_Defining_Program_Unit_Name)
2809 (K2 = N_Expanded_Name or else
2810 K2 = N_Selected_Component or else
2811 K2 = N_Defining_Program_Unit_Name)
2814 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
2816 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
2821 end Designate_Same_Unit;
2823 --------------------------
2824 -- Enclosing_CPP_Parent --
2825 --------------------------
2827 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
2828 Parent_Typ : Entity_Id := Typ;
2831 while not Is_CPP_Class (Parent_Typ)
2832 and then Etype (Parent_Typ) /= Parent_Typ
2834 Parent_Typ := Etype (Parent_Typ);
2836 if Is_Private_Type (Parent_Typ) then
2837 Parent_Typ := Full_View (Base_Type (Parent_Typ));
2841 pragma Assert (Is_CPP_Class (Parent_Typ));
2843 end Enclosing_CPP_Parent;
2845 ----------------------------
2846 -- Enclosing_Generic_Body --
2847 ----------------------------
2849 function Enclosing_Generic_Body
2850 (N : Node_Id) return Node_Id
2858 while Present (P) loop
2859 if Nkind (P) = N_Package_Body
2860 or else Nkind (P) = N_Subprogram_Body
2862 Spec := Corresponding_Spec (P);
2864 if Present (Spec) then
2865 Decl := Unit_Declaration_Node (Spec);
2867 if Nkind (Decl) = N_Generic_Package_Declaration
2868 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
2879 end Enclosing_Generic_Body;
2881 ----------------------------
2882 -- Enclosing_Generic_Unit --
2883 ----------------------------
2885 function Enclosing_Generic_Unit
2886 (N : Node_Id) return Node_Id
2894 while Present (P) loop
2895 if Nkind (P) = N_Generic_Package_Declaration
2896 or else Nkind (P) = N_Generic_Subprogram_Declaration
2900 elsif Nkind (P) = N_Package_Body
2901 or else Nkind (P) = N_Subprogram_Body
2903 Spec := Corresponding_Spec (P);
2905 if Present (Spec) then
2906 Decl := Unit_Declaration_Node (Spec);
2908 if Nkind (Decl) = N_Generic_Package_Declaration
2909 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
2920 end Enclosing_Generic_Unit;
2922 -------------------------------
2923 -- Enclosing_Lib_Unit_Entity --
2924 -------------------------------
2926 function Enclosing_Lib_Unit_Entity return Entity_Id is
2927 Unit_Entity : Entity_Id;
2930 -- Look for enclosing library unit entity by following scope links.
2931 -- Equivalent to, but faster than indexing through the scope stack.
2933 Unit_Entity := Current_Scope;
2934 while (Present (Scope (Unit_Entity))
2935 and then Scope (Unit_Entity) /= Standard_Standard)
2936 and not Is_Child_Unit (Unit_Entity)
2938 Unit_Entity := Scope (Unit_Entity);
2942 end Enclosing_Lib_Unit_Entity;
2944 -----------------------------
2945 -- Enclosing_Lib_Unit_Node --
2946 -----------------------------
2948 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
2949 Current_Node : Node_Id;
2953 while Present (Current_Node)
2954 and then Nkind (Current_Node) /= N_Compilation_Unit
2956 Current_Node := Parent (Current_Node);
2959 if Nkind (Current_Node) /= N_Compilation_Unit then
2963 return Current_Node;
2964 end Enclosing_Lib_Unit_Node;
2966 -----------------------
2967 -- Enclosing_Package --
2968 -----------------------
2970 function Enclosing_Package (E : Entity_Id) return Entity_Id is
2971 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
2974 if Dynamic_Scope = Standard_Standard then
2975 return Standard_Standard;
2977 elsif Dynamic_Scope = Empty then
2980 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
2983 return Dynamic_Scope;
2986 return Enclosing_Package (Dynamic_Scope);
2988 end Enclosing_Package;
2990 --------------------------
2991 -- Enclosing_Subprogram --
2992 --------------------------
2994 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
2995 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
2998 if Dynamic_Scope = Standard_Standard then
3001 elsif Dynamic_Scope = Empty then
3004 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
3005 return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
3007 elsif Ekind (Dynamic_Scope) = E_Block
3008 or else Ekind (Dynamic_Scope) = E_Return_Statement
3010 return Enclosing_Subprogram (Dynamic_Scope);
3012 elsif Ekind (Dynamic_Scope) = E_Task_Type then
3013 return Get_Task_Body_Procedure (Dynamic_Scope);
3015 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
3016 and then Present (Full_View (Dynamic_Scope))
3017 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
3019 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
3021 -- No body is generated if the protected operation is eliminated
3023 elsif Convention (Dynamic_Scope) = Convention_Protected
3024 and then not Is_Eliminated (Dynamic_Scope)
3025 and then Present (Protected_Body_Subprogram (Dynamic_Scope))
3027 return Protected_Body_Subprogram (Dynamic_Scope);
3030 return Dynamic_Scope;
3032 end Enclosing_Subprogram;
3034 ------------------------
3035 -- Ensure_Freeze_Node --
3036 ------------------------
3038 procedure Ensure_Freeze_Node (E : Entity_Id) is
3042 if No (Freeze_Node (E)) then
3043 FN := Make_Freeze_Entity (Sloc (E));
3044 Set_Has_Delayed_Freeze (E);
3045 Set_Freeze_Node (E, FN);
3046 Set_Access_Types_To_Process (FN, No_Elist);
3047 Set_TSS_Elist (FN, No_Elist);
3050 end Ensure_Freeze_Node;
3056 procedure Enter_Name (Def_Id : Entity_Id) is
3057 C : constant Entity_Id := Current_Entity (Def_Id);
3058 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
3059 S : constant Entity_Id := Current_Scope;
3062 Generate_Definition (Def_Id);
3064 -- Add new name to current scope declarations. Check for duplicate
3065 -- declaration, which may or may not be a genuine error.
3069 -- Case of previous entity entered because of a missing declaration
3070 -- or else a bad subtype indication. Best is to use the new entity,
3071 -- and make the previous one invisible.
3073 if Etype (E) = Any_Type then
3074 Set_Is_Immediately_Visible (E, False);
3076 -- Case of renaming declaration constructed for package instances.
3077 -- if there is an explicit declaration with the same identifier,
3078 -- the renaming is not immediately visible any longer, but remains
3079 -- visible through selected component notation.
3081 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
3082 and then not Comes_From_Source (E)
3084 Set_Is_Immediately_Visible (E, False);
3086 -- The new entity may be the package renaming, which has the same
3087 -- same name as a generic formal which has been seen already.
3089 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
3090 and then not Comes_From_Source (Def_Id)
3092 Set_Is_Immediately_Visible (E, False);
3094 -- For a fat pointer corresponding to a remote access to subprogram,
3095 -- we use the same identifier as the RAS type, so that the proper
3096 -- name appears in the stub. This type is only retrieved through
3097 -- the RAS type and never by visibility, and is not added to the
3098 -- visibility list (see below).
3100 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
3101 and then Present (Corresponding_Remote_Type (Def_Id))
3105 -- A controller component for a type extension overrides the
3106 -- inherited component.
3108 elsif Chars (E) = Name_uController then
3111 -- Case of an implicit operation or derived literal. The new entity
3112 -- hides the implicit one, which is removed from all visibility,
3113 -- i.e. the entity list of its scope, and homonym chain of its name.
3115 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
3116 or else Is_Internal (E)
3120 Prev_Vis : Entity_Id;
3121 Decl : constant Node_Id := Parent (E);
3124 -- If E is an implicit declaration, it cannot be the first
3125 -- entity in the scope.
3127 Prev := First_Entity (Current_Scope);
3128 while Present (Prev)
3129 and then Next_Entity (Prev) /= E
3136 -- If E is not on the entity chain of the current scope,
3137 -- it is an implicit declaration in the generic formal
3138 -- part of a generic subprogram. When analyzing the body,
3139 -- the generic formals are visible but not on the entity
3140 -- chain of the subprogram. The new entity will become
3141 -- the visible one in the body.
3144 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
3148 Set_Next_Entity (Prev, Next_Entity (E));
3150 if No (Next_Entity (Prev)) then
3151 Set_Last_Entity (Current_Scope, Prev);
3154 if E = Current_Entity (E) then
3158 Prev_Vis := Current_Entity (E);
3159 while Homonym (Prev_Vis) /= E loop
3160 Prev_Vis := Homonym (Prev_Vis);
3164 if Present (Prev_Vis) then
3166 -- Skip E in the visibility chain
3168 Set_Homonym (Prev_Vis, Homonym (E));
3171 Set_Name_Entity_Id (Chars (E), Homonym (E));
3176 -- This section of code could use a comment ???
3178 elsif Present (Etype (E))
3179 and then Is_Concurrent_Type (Etype (E))
3184 -- If the homograph is a protected component renaming, it should not
3185 -- be hiding the current entity. Such renamings are treated as weak
3188 elsif Is_Prival (E) then
3189 Set_Is_Immediately_Visible (E, False);
3191 -- In this case the current entity is a protected component renaming.
3192 -- Perform minimal decoration by setting the scope and return since
3193 -- the prival should not be hiding other visible entities.
3195 elsif Is_Prival (Def_Id) then
3196 Set_Scope (Def_Id, Current_Scope);
3199 -- Analogous to privals, the discriminal generated for an entry index
3200 -- parameter acts as a weak declaration. Perform minimal decoration
3201 -- to avoid bogus errors.
3203 elsif Is_Discriminal (Def_Id)
3204 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
3206 Set_Scope (Def_Id, Current_Scope);
3209 -- In the body or private part of an instance, a type extension may
3210 -- introduce a component with the same name as that of an actual. The
3211 -- legality rule is not enforced, but the semantics of the full type
3212 -- with two components of same name are not clear at this point???
3214 elsif In_Instance_Not_Visible then
3217 -- When compiling a package body, some child units may have become
3218 -- visible. They cannot conflict with local entities that hide them.
3220 elsif Is_Child_Unit (E)
3221 and then In_Open_Scopes (Scope (E))
3222 and then not Is_Immediately_Visible (E)
3226 -- Conversely, with front-end inlining we may compile the parent body
3227 -- first, and a child unit subsequently. The context is now the
3228 -- parent spec, and body entities are not visible.
3230 elsif Is_Child_Unit (Def_Id)
3231 and then Is_Package_Body_Entity (E)
3232 and then not In_Package_Body (Current_Scope)
3236 -- Case of genuine duplicate declaration
3239 Error_Msg_Sloc := Sloc (E);
3241 -- If the previous declaration is an incomplete type declaration
3242 -- this may be an attempt to complete it with a private type. The
3243 -- following avoids confusing cascaded errors.
3245 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
3246 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
3249 ("incomplete type cannot be completed with a private " &
3250 "declaration", Parent (Def_Id));
3251 Set_Is_Immediately_Visible (E, False);
3252 Set_Full_View (E, Def_Id);
3254 -- An inherited component of a record conflicts with a new
3255 -- discriminant. The discriminant is inserted first in the scope,
3256 -- but the error should be posted on it, not on the component.
3258 elsif Ekind (E) = E_Discriminant
3259 and then Present (Scope (Def_Id))
3260 and then Scope (Def_Id) /= Current_Scope
3262 Error_Msg_Sloc := Sloc (Def_Id);
3263 Error_Msg_N ("& conflicts with declaration#", E);
3266 -- If the name of the unit appears in its own context clause, a
3267 -- dummy package with the name has already been created, and the
3268 -- error emitted. Try to continue quietly.
3270 elsif Error_Posted (E)
3271 and then Sloc (E) = No_Location
3272 and then Nkind (Parent (E)) = N_Package_Specification
3273 and then Current_Scope = Standard_Standard
3275 Set_Scope (Def_Id, Current_Scope);
3279 Error_Msg_N ("& conflicts with declaration#", Def_Id);
3281 -- Avoid cascaded messages with duplicate components in
3284 if Ekind_In (E, E_Component, E_Discriminant) then
3289 if Nkind (Parent (Parent (Def_Id))) =
3290 N_Generic_Subprogram_Declaration
3292 Defining_Entity (Specification (Parent (Parent (Def_Id))))
3294 Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
3297 -- If entity is in standard, then we are in trouble, because it
3298 -- means that we have a library package with a duplicated name.
3299 -- That's hard to recover from, so abort!
3301 if S = Standard_Standard then
3302 raise Unrecoverable_Error;
3304 -- Otherwise we continue with the declaration. Having two
3305 -- identical declarations should not cause us too much trouble!
3313 -- If we fall through, declaration is OK, at least OK enough to continue
3315 -- If Def_Id is a discriminant or a record component we are in the midst
3316 -- of inheriting components in a derived record definition. Preserve
3317 -- their Ekind and Etype.
3319 if Ekind_In (Def_Id, E_Discriminant, E_Component) then
3322 -- If a type is already set, leave it alone (happens when a type
3323 -- declaration is reanalyzed following a call to the optimizer).
3325 elsif Present (Etype (Def_Id)) then
3328 -- Otherwise, the kind E_Void insures that premature uses of the entity
3329 -- will be detected. Any_Type insures that no cascaded errors will occur
3332 Set_Ekind (Def_Id, E_Void);
3333 Set_Etype (Def_Id, Any_Type);
3336 -- Inherited discriminants and components in derived record types are
3337 -- immediately visible. Itypes are not.
3339 if Ekind_In (Def_Id, E_Discriminant, E_Component)
3340 or else (No (Corresponding_Remote_Type (Def_Id))
3341 and then not Is_Itype (Def_Id))
3343 Set_Is_Immediately_Visible (Def_Id);
3344 Set_Current_Entity (Def_Id);
3347 Set_Homonym (Def_Id, C);
3348 Append_Entity (Def_Id, S);
3349 Set_Public_Status (Def_Id);
3351 -- Declaring a homonym is not allowed in SPARK ...
3354 and then Restriction_Check_Required (SPARK)
3358 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
3359 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
3360 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C);
3363 -- ... unless the new declaration is in a subprogram, and the
3364 -- visible declaration is a variable declaration or a parameter
3365 -- specification outside that subprogram.
3367 if Present (Enclosing_Subp)
3368 and then Nkind_In (Parent (C), N_Object_Declaration,
3369 N_Parameter_Specification)
3370 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
3374 -- ... or the new declaration is in a package, and the visible
3375 -- declaration occurs outside that package.
3377 elsif Present (Enclosing_Pack)
3378 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
3382 -- ... or the new declaration is a component declaration in a
3383 -- record type definition.
3385 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
3388 -- Don't issue error for non-source entities
3390 elsif Comes_From_Source (Def_Id)
3391 and then Comes_From_Source (C)
3393 Error_Msg_Sloc := Sloc (C);
3394 Check_SPARK_Restriction
3395 ("redeclaration of identifier &#", Def_Id);
3400 -- Warn if new entity hides an old one
3402 if Warn_On_Hiding and then Present (C)
3404 -- Don't warn for record components since they always have a well
3405 -- defined scope which does not confuse other uses. Note that in
3406 -- some cases, Ekind has not been set yet.
3408 and then Ekind (C) /= E_Component
3409 and then Ekind (C) /= E_Discriminant
3410 and then Nkind (Parent (C)) /= N_Component_Declaration
3411 and then Ekind (Def_Id) /= E_Component
3412 and then Ekind (Def_Id) /= E_Discriminant
3413 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
3415 -- Don't warn for one character variables. It is too common to use
3416 -- such variables as locals and will just cause too many false hits.
3418 and then Length_Of_Name (Chars (C)) /= 1
3420 -- Don't warn for non-source entities
3422 and then Comes_From_Source (C)
3423 and then Comes_From_Source (Def_Id)
3425 -- Don't warn unless entity in question is in extended main source
3427 and then In_Extended_Main_Source_Unit (Def_Id)
3429 -- Finally, the hidden entity must be either immediately visible or
3430 -- use visible (i.e. from a used package).
3433 (Is_Immediately_Visible (C)
3435 Is_Potentially_Use_Visible (C))
3437 Error_Msg_Sloc := Sloc (C);
3438 Error_Msg_N ("declaration hides &#?", Def_Id);
3442 --------------------------
3443 -- Explain_Limited_Type --
3444 --------------------------
3446 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
3450 -- For array, component type must be limited
3452 if Is_Array_Type (T) then
3453 Error_Msg_Node_2 := T;
3455 ("\component type& of type& is limited", N, Component_Type (T));
3456 Explain_Limited_Type (Component_Type (T), N);
3458 elsif Is_Record_Type (T) then
3460 -- No need for extra messages if explicit limited record
3462 if Is_Limited_Record (Base_Type (T)) then
3466 -- Otherwise find a limited component. Check only components that
3467 -- come from source, or inherited components that appear in the
3468 -- source of the ancestor.
3470 C := First_Component (T);
3471 while Present (C) loop
3472 if Is_Limited_Type (Etype (C))
3474 (Comes_From_Source (C)
3476 (Present (Original_Record_Component (C))
3478 Comes_From_Source (Original_Record_Component (C))))
3480 Error_Msg_Node_2 := T;
3481 Error_Msg_NE ("\component& of type& has limited type", N, C);
3482 Explain_Limited_Type (Etype (C), N);
3489 -- The type may be declared explicitly limited, even if no component
3490 -- of it is limited, in which case we fall out of the loop.
3493 end Explain_Limited_Type;
3499 procedure Find_Actual
3501 Formal : out Entity_Id;
3504 Parnt : constant Node_Id := Parent (N);
3508 if (Nkind (Parnt) = N_Indexed_Component
3510 Nkind (Parnt) = N_Selected_Component)
3511 and then N = Prefix (Parnt)
3513 Find_Actual (Parnt, Formal, Call);
3516 elsif Nkind (Parnt) = N_Parameter_Association
3517 and then N = Explicit_Actual_Parameter (Parnt)
3519 Call := Parent (Parnt);
3521 elsif Nkind_In (Parnt, N_Procedure_Call_Statement, N_Function_Call) then
3530 -- If we have a call to a subprogram look for the parameter. Note that
3531 -- we exclude overloaded calls, since we don't know enough to be sure
3532 -- of giving the right answer in this case.
3534 if Is_Entity_Name (Name (Call))
3535 and then Present (Entity (Name (Call)))
3536 and then Is_Overloadable (Entity (Name (Call)))
3537 and then not Is_Overloaded (Name (Call))
3539 -- Fall here if we are definitely a parameter
3541 Actual := First_Actual (Call);
3542 Formal := First_Formal (Entity (Name (Call)));
3543 while Present (Formal) and then Present (Actual) loop
3547 Actual := Next_Actual (Actual);
3548 Formal := Next_Formal (Formal);
3553 -- Fall through here if we did not find matching actual
3559 ---------------------------
3560 -- Find_Body_Discriminal --
3561 ---------------------------
3563 function Find_Body_Discriminal
3564 (Spec_Discriminant : Entity_Id) return Entity_Id
3566 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
3568 Tsk : constant Entity_Id :=
3569 Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
3573 -- Find discriminant of original concurrent type, and use its current
3574 -- discriminal, which is the renaming within the task/protected body.
3576 Disc := First_Discriminant (Tsk);
3577 while Present (Disc) loop
3578 if Chars (Disc) = Chars (Spec_Discriminant) then
3579 return Discriminal (Disc);
3582 Next_Discriminant (Disc);
3585 -- That loop should always succeed in finding a matching entry and
3586 -- returning. Fatal error if not.
3588 raise Program_Error;
3589 end Find_Body_Discriminal;
3591 -------------------------------------
3592 -- Find_Corresponding_Discriminant --
3593 -------------------------------------
3595 function Find_Corresponding_Discriminant
3597 Typ : Entity_Id) return Entity_Id
3599 Par_Disc : Entity_Id;
3600 Old_Disc : Entity_Id;
3601 New_Disc : Entity_Id;
3604 Par_Disc := Original_Record_Component (Original_Discriminant (Id));
3606 -- The original type may currently be private, and the discriminant
3607 -- only appear on its full view.
3609 if Is_Private_Type (Scope (Par_Disc))
3610 and then not Has_Discriminants (Scope (Par_Disc))
3611 and then Present (Full_View (Scope (Par_Disc)))
3613 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
3615 Old_Disc := First_Discriminant (Scope (Par_Disc));
3618 if Is_Class_Wide_Type (Typ) then
3619 New_Disc := First_Discriminant (Root_Type (Typ));
3621 New_Disc := First_Discriminant (Typ);
3624 while Present (Old_Disc) and then Present (New_Disc) loop
3625 if Old_Disc = Par_Disc then
3628 Next_Discriminant (Old_Disc);
3629 Next_Discriminant (New_Disc);
3633 -- Should always find it
3635 raise Program_Error;
3636 end Find_Corresponding_Discriminant;
3638 --------------------------
3639 -- Find_Overlaid_Entity --
3640 --------------------------
3642 procedure Find_Overlaid_Entity
3644 Ent : out Entity_Id;
3650 -- We are looking for one of the two following forms:
3652 -- for X'Address use Y'Address
3656 -- Const : constant Address := expr;
3658 -- for X'Address use Const;
3660 -- In the second case, the expr is either Y'Address, or recursively a
3661 -- constant that eventually references Y'Address.
3666 if Nkind (N) = N_Attribute_Definition_Clause
3667 and then Chars (N) = Name_Address
3669 Expr := Expression (N);
3671 -- This loop checks the form of the expression for Y'Address,
3672 -- using recursion to deal with intermediate constants.
3675 -- Check for Y'Address
3677 if Nkind (Expr) = N_Attribute_Reference
3678 and then Attribute_Name (Expr) = Name_Address
3680 Expr := Prefix (Expr);
3683 -- Check for Const where Const is a constant entity
3685 elsif Is_Entity_Name (Expr)
3686 and then Ekind (Entity (Expr)) = E_Constant
3688 Expr := Constant_Value (Entity (Expr));
3690 -- Anything else does not need checking
3697 -- This loop checks the form of the prefix for an entity,
3698 -- using recursion to deal with intermediate components.
3701 -- Check for Y where Y is an entity
3703 if Is_Entity_Name (Expr) then
3704 Ent := Entity (Expr);
3707 -- Check for components
3710 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) then
3712 Expr := Prefix (Expr);
3715 -- Anything else does not need checking
3722 end Find_Overlaid_Entity;
3724 -------------------------
3725 -- Find_Parameter_Type --
3726 -------------------------
3728 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
3730 if Nkind (Param) /= N_Parameter_Specification then
3733 -- For an access parameter, obtain the type from the formal entity
3734 -- itself, because access to subprogram nodes do not carry a type.
3735 -- Shouldn't we always use the formal entity ???
3737 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
3738 return Etype (Defining_Identifier (Param));
3741 return Etype (Parameter_Type (Param));
3743 end Find_Parameter_Type;
3745 -----------------------------
3746 -- Find_Static_Alternative --
3747 -----------------------------
3749 function Find_Static_Alternative (N : Node_Id) return Node_Id is
3750 Expr : constant Node_Id := Expression (N);
3751 Val : constant Uint := Expr_Value (Expr);
3756 Alt := First (Alternatives (N));
3759 if Nkind (Alt) /= N_Pragma then
3760 Choice := First (Discrete_Choices (Alt));
3761 while Present (Choice) loop
3763 -- Others choice, always matches
3765 if Nkind (Choice) = N_Others_Choice then
3768 -- Range, check if value is in the range
3770 elsif Nkind (Choice) = N_Range then
3772 Val >= Expr_Value (Low_Bound (Choice))
3774 Val <= Expr_Value (High_Bound (Choice));
3776 -- Choice is a subtype name. Note that we know it must
3777 -- be a static subtype, since otherwise it would have
3778 -- been diagnosed as illegal.
3780 elsif Is_Entity_Name (Choice)
3781 and then Is_Type (Entity (Choice))
3783 exit Search when Is_In_Range (Expr, Etype (Choice),
3784 Assume_Valid => False);
3786 -- Choice is a subtype indication
3788 elsif Nkind (Choice) = N_Subtype_Indication then
3790 C : constant Node_Id := Constraint (Choice);
3791 R : constant Node_Id := Range_Expression (C);
3795 Val >= Expr_Value (Low_Bound (R))
3797 Val <= Expr_Value (High_Bound (R));
3800 -- Choice is a simple expression
3803 exit Search when Val = Expr_Value (Choice);
3811 pragma Assert (Present (Alt));
3814 -- The above loop *must* terminate by finding a match, since
3815 -- we know the case statement is valid, and the value of the
3816 -- expression is known at compile time. When we fall out of
3817 -- the loop, Alt points to the alternative that we know will
3818 -- be selected at run time.
3821 end Find_Static_Alternative;
3827 function First_Actual (Node : Node_Id) return Node_Id is
3831 if No (Parameter_Associations (Node)) then
3835 N := First (Parameter_Associations (Node));
3837 if Nkind (N) = N_Parameter_Association then
3838 return First_Named_Actual (Node);
3844 -----------------------
3845 -- Gather_Components --
3846 -----------------------
3848 procedure Gather_Components
3850 Comp_List : Node_Id;
3851 Governed_By : List_Id;
3853 Report_Errors : out Boolean)
3857 Discrete_Choice : Node_Id;
3858 Comp_Item : Node_Id;
3860 Discrim : Entity_Id;
3861 Discrim_Name : Node_Id;
3862 Discrim_Value : Node_Id;
3865 Report_Errors := False;
3867 if No (Comp_List) or else Null_Present (Comp_List) then
3870 elsif Present (Component_Items (Comp_List)) then
3871 Comp_Item := First (Component_Items (Comp_List));
3877 while Present (Comp_Item) loop
3879 -- Skip the tag of a tagged record, the interface tags, as well
3880 -- as all items that are not user components (anonymous types,
3881 -- rep clauses, Parent field, controller field).
3883 if Nkind (Comp_Item) = N_Component_Declaration then
3885 Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
3887 if not Is_Tag (Comp)
3888 and then Chars (Comp) /= Name_uParent
3889 and then Chars (Comp) /= Name_uController
3891 Append_Elmt (Comp, Into);
3899 if No (Variant_Part (Comp_List)) then
3902 Discrim_Name := Name (Variant_Part (Comp_List));
3903 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
3906 -- Look for the discriminant that governs this variant part.
3907 -- The discriminant *must* be in the Governed_By List
3909 Assoc := First (Governed_By);
3910 Find_Constraint : loop
3911 Discrim := First (Choices (Assoc));
3912 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
3913 or else (Present (Corresponding_Discriminant (Entity (Discrim)))
3915 Chars (Corresponding_Discriminant (Entity (Discrim)))
3916 = Chars (Discrim_Name))
3917 or else Chars (Original_Record_Component (Entity (Discrim)))
3918 = Chars (Discrim_Name);
3920 if No (Next (Assoc)) then
3921 if not Is_Constrained (Typ)
3922 and then Is_Derived_Type (Typ)
3923 and then Present (Stored_Constraint (Typ))
3925 -- If the type is a tagged type with inherited discriminants,
3926 -- use the stored constraint on the parent in order to find
3927 -- the values of discriminants that are otherwise hidden by an
3928 -- explicit constraint. Renamed discriminants are handled in
3931 -- If several parent discriminants are renamed by a single
3932 -- discriminant of the derived type, the call to obtain the
3933 -- Corresponding_Discriminant field only retrieves the last
3934 -- of them. We recover the constraint on the others from the
3935 -- Stored_Constraint as well.
3942 D := First_Discriminant (Etype (Typ));
3943 C := First_Elmt (Stored_Constraint (Typ));
3944 while Present (D) and then Present (C) loop
3945 if Chars (Discrim_Name) = Chars (D) then
3946 if Is_Entity_Name (Node (C))
3947 and then Entity (Node (C)) = Entity (Discrim)
3949 -- D is renamed by Discrim, whose value is given in
3956 Make_Component_Association (Sloc (Typ),
3958 (New_Occurrence_Of (D, Sloc (Typ))),
3959 Duplicate_Subexpr_No_Checks (Node (C)));
3961 exit Find_Constraint;
3964 Next_Discriminant (D);
3971 if No (Next (Assoc)) then
3972 Error_Msg_NE (" missing value for discriminant&",
3973 First (Governed_By), Discrim_Name);
3974 Report_Errors := True;
3979 end loop Find_Constraint;
3981 Discrim_Value := Expression (Assoc);
3983 if not Is_OK_Static_Expression (Discrim_Value) then
3985 ("value for discriminant & must be static!",
3986 Discrim_Value, Discrim);
3987 Why_Not_Static (Discrim_Value);
3988 Report_Errors := True;
3992 Search_For_Discriminant_Value : declare
3998 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
4001 Find_Discrete_Value : while Present (Variant) loop
4002 Discrete_Choice := First (Discrete_Choices (Variant));
4003 while Present (Discrete_Choice) loop
4005 exit Find_Discrete_Value when
4006 Nkind (Discrete_Choice) = N_Others_Choice;
4008 Get_Index_Bounds (Discrete_Choice, Low, High);
4010 UI_Low := Expr_Value (Low);
4011 UI_High := Expr_Value (High);
4013 exit Find_Discrete_Value when
4014 UI_Low <= UI_Discrim_Value
4016 UI_High >= UI_Discrim_Value;
4018 Next (Discrete_Choice);
4021 Next_Non_Pragma (Variant);
4022 end loop Find_Discrete_Value;
4023 end Search_For_Discriminant_Value;
4025 if No (Variant) then
4027 ("value of discriminant & is out of range", Discrim_Value, Discrim);
4028 Report_Errors := True;
4032 -- If we have found the corresponding choice, recursively add its
4033 -- components to the Into list.
4035 Gather_Components (Empty,
4036 Component_List (Variant), Governed_By, Into, Report_Errors);
4037 end Gather_Components;
4039 ------------------------
4040 -- Get_Actual_Subtype --
4041 ------------------------
4043 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
4044 Typ : constant Entity_Id := Etype (N);
4045 Utyp : Entity_Id := Underlying_Type (Typ);
4054 -- If what we have is an identifier that references a subprogram
4055 -- formal, or a variable or constant object, then we get the actual
4056 -- subtype from the referenced entity if one has been built.
4058 if Nkind (N) = N_Identifier
4060 (Is_Formal (Entity (N))
4061 or else Ekind (Entity (N)) = E_Constant
4062 or else Ekind (Entity (N)) = E_Variable)
4063 and then Present (Actual_Subtype (Entity (N)))
4065 return Actual_Subtype (Entity (N));
4067 -- Actual subtype of unchecked union is always itself. We never need
4068 -- the "real" actual subtype. If we did, we couldn't get it anyway
4069 -- because the discriminant is not available. The restrictions on
4070 -- Unchecked_Union are designed to make sure that this is OK.
4072 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
4075 -- Here for the unconstrained case, we must find actual subtype
4076 -- No actual subtype is available, so we must build it on the fly.
4078 -- Checking the type, not the underlying type, for constrainedness
4079 -- seems to be necessary. Maybe all the tests should be on the type???
4081 elsif (not Is_Constrained (Typ))
4082 and then (Is_Array_Type (Utyp)
4083 or else (Is_Record_Type (Utyp)
4084 and then Has_Discriminants (Utyp)))
4085 and then not Has_Unknown_Discriminants (Utyp)
4086 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
4088 -- Nothing to do if in spec expression (why not???)
4090 if In_Spec_Expression then
4093 elsif Is_Private_Type (Typ)
4094 and then not Has_Discriminants (Typ)
4096 -- If the type has no discriminants, there is no subtype to
4097 -- build, even if the underlying type is discriminated.
4101 -- Else build the actual subtype
4104 Decl := Build_Actual_Subtype (Typ, N);
4105 Atyp := Defining_Identifier (Decl);
4107 -- If Build_Actual_Subtype generated a new declaration then use it
4111 -- The actual subtype is an Itype, so analyze the declaration,
4112 -- but do not attach it to the tree, to get the type defined.
4114 Set_Parent (Decl, N);
4115 Set_Is_Itype (Atyp);
4116 Analyze (Decl, Suppress => All_Checks);
4117 Set_Associated_Node_For_Itype (Atyp, N);
4118 Set_Has_Delayed_Freeze (Atyp, False);
4120 -- We need to freeze the actual subtype immediately. This is
4121 -- needed, because otherwise this Itype will not get frozen
4122 -- at all, and it is always safe to freeze on creation because
4123 -- any associated types must be frozen at this point.
4125 Freeze_Itype (Atyp, N);
4128 -- Otherwise we did not build a declaration, so return original
4135 -- For all remaining cases, the actual subtype is the same as
4136 -- the nominal type.
4141 end Get_Actual_Subtype;
4143 -------------------------------------
4144 -- Get_Actual_Subtype_If_Available --
4145 -------------------------------------
4147 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
4148 Typ : constant Entity_Id := Etype (N);
4151 -- If what we have is an identifier that references a subprogram
4152 -- formal, or a variable or constant object, then we get the actual
4153 -- subtype from the referenced entity if one has been built.
4155 if Nkind (N) = N_Identifier
4157 (Is_Formal (Entity (N))
4158 or else Ekind (Entity (N)) = E_Constant
4159 or else Ekind (Entity (N)) = E_Variable)
4160 and then Present (Actual_Subtype (Entity (N)))
4162 return Actual_Subtype (Entity (N));
4164 -- Otherwise the Etype of N is returned unchanged
4169 end Get_Actual_Subtype_If_Available;
4171 -------------------------------
4172 -- Get_Default_External_Name --
4173 -------------------------------
4175 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
4177 Get_Decoded_Name_String (Chars (E));
4179 if Opt.External_Name_Imp_Casing = Uppercase then
4180 Set_Casing (All_Upper_Case);
4182 Set_Casing (All_Lower_Case);
4186 Make_String_Literal (Sloc (E),
4187 Strval => String_From_Name_Buffer);
4188 end Get_Default_External_Name;
4190 ---------------------------
4191 -- Get_Enum_Lit_From_Pos --
4192 ---------------------------
4194 function Get_Enum_Lit_From_Pos
4197 Loc : Source_Ptr) return Node_Id
4202 -- In the case where the literal is of type Character, Wide_Character
4203 -- or Wide_Wide_Character or of a type derived from them, there needs
4204 -- to be some special handling since there is no explicit chain of
4205 -- literals to search. Instead, an N_Character_Literal node is created
4206 -- with the appropriate Char_Code and Chars fields.
4208 if Is_Standard_Character_Type (T) then
4209 Set_Character_Literal_Name (UI_To_CC (Pos));
4211 Make_Character_Literal (Loc,
4213 Char_Literal_Value => Pos);
4215 -- For all other cases, we have a complete table of literals, and
4216 -- we simply iterate through the chain of literal until the one
4217 -- with the desired position value is found.
4221 Lit := First_Literal (Base_Type (T));
4222 for J in 1 .. UI_To_Int (Pos) loop
4226 return New_Occurrence_Of (Lit, Loc);
4228 end Get_Enum_Lit_From_Pos;
4230 ------------------------
4231 -- Get_Generic_Entity --
4232 ------------------------
4234 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
4235 Ent : constant Entity_Id := Entity (Name (N));
4237 if Present (Renamed_Object (Ent)) then
4238 return Renamed_Object (Ent);
4242 end Get_Generic_Entity;
4244 ----------------------
4245 -- Get_Index_Bounds --
4246 ----------------------
4248 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
4249 Kind : constant Node_Kind := Nkind (N);
4253 if Kind = N_Range then
4255 H := High_Bound (N);
4257 elsif Kind = N_Subtype_Indication then
4258 R := Range_Expression (Constraint (N));
4266 L := Low_Bound (Range_Expression (Constraint (N)));
4267 H := High_Bound (Range_Expression (Constraint (N)));
4270 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
4271 if Error_Posted (Scalar_Range (Entity (N))) then
4275 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
4276 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
4279 L := Low_Bound (Scalar_Range (Entity (N)));
4280 H := High_Bound (Scalar_Range (Entity (N)));
4284 -- N is an expression, indicating a range with one value
4289 end Get_Index_Bounds;
4291 ----------------------------------
4292 -- Get_Library_Unit_Name_string --
4293 ----------------------------------
4295 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
4296 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
4299 Get_Unit_Name_String (Unit_Name_Id);
4301 -- Remove seven last character (" (spec)" or " (body)")
4303 Name_Len := Name_Len - 7;
4304 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
4305 end Get_Library_Unit_Name_String;
4307 ------------------------
4308 -- Get_Name_Entity_Id --
4309 ------------------------
4311 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
4313 return Entity_Id (Get_Name_Table_Info (Id));
4314 end Get_Name_Entity_Id;
4320 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
4322 return Get_Pragma_Id (Pragma_Name (N));
4325 ---------------------------
4326 -- Get_Referenced_Object --
4327 ---------------------------
4329 function Get_Referenced_Object (N : Node_Id) return Node_Id is
4334 while Is_Entity_Name (R)
4335 and then Present (Renamed_Object (Entity (R)))
4337 R := Renamed_Object (Entity (R));
4341 end Get_Referenced_Object;
4343 ------------------------
4344 -- Get_Renamed_Entity --
4345 ------------------------
4347 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
4352 while Present (Renamed_Entity (R)) loop
4353 R := Renamed_Entity (R);
4357 end Get_Renamed_Entity;
4359 -------------------------
4360 -- Get_Subprogram_Body --
4361 -------------------------
4363 function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
4367 Decl := Unit_Declaration_Node (E);
4369 if Nkind (Decl) = N_Subprogram_Body then
4372 -- The below comment is bad, because it is possible for
4373 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
4375 else -- Nkind (Decl) = N_Subprogram_Declaration
4377 if Present (Corresponding_Body (Decl)) then
4378 return Unit_Declaration_Node (Corresponding_Body (Decl));
4380 -- Imported subprogram case
4386 end Get_Subprogram_Body;
4388 ---------------------------
4389 -- Get_Subprogram_Entity --
4390 ---------------------------
4392 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
4397 if Nkind (Nod) = N_Accept_Statement then
4398 Nam := Entry_Direct_Name (Nod);
4400 -- For an entry call, the prefix of the call is a selected component.
4401 -- Need additional code for internal calls ???
4403 elsif Nkind (Nod) = N_Entry_Call_Statement then
4404 if Nkind (Name (Nod)) = N_Selected_Component then
4405 Nam := Entity (Selector_Name (Name (Nod)));
4414 if Nkind (Nam) = N_Explicit_Dereference then
4415 Proc := Etype (Prefix (Nam));
4416 elsif Is_Entity_Name (Nam) then
4417 Proc := Entity (Nam);
4422 if Is_Object (Proc) then
4423 Proc := Etype (Proc);
4426 if Ekind (Proc) = E_Access_Subprogram_Type then
4427 Proc := Directly_Designated_Type (Proc);
4430 if not Is_Subprogram (Proc)
4431 and then Ekind (Proc) /= E_Subprogram_Type
4437 end Get_Subprogram_Entity;
4439 -----------------------------
4440 -- Get_Task_Body_Procedure --
4441 -----------------------------
4443 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
4445 -- Note: A task type may be the completion of a private type with
4446 -- discriminants. When performing elaboration checks on a task
4447 -- declaration, the current view of the type may be the private one,
4448 -- and the procedure that holds the body of the task is held in its
4451 -- This is an odd function, why not have Task_Body_Procedure do
4452 -- the following digging???
4454 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
4455 end Get_Task_Body_Procedure;
4457 -----------------------
4458 -- Has_Access_Values --
4459 -----------------------
4461 function Has_Access_Values (T : Entity_Id) return Boolean is
4462 Typ : constant Entity_Id := Underlying_Type (T);
4465 -- Case of a private type which is not completed yet. This can only
4466 -- happen in the case of a generic format type appearing directly, or
4467 -- as a component of the type to which this function is being applied
4468 -- at the top level. Return False in this case, since we certainly do
4469 -- not know that the type contains access types.
4474 elsif Is_Access_Type (Typ) then
4477 elsif Is_Array_Type (Typ) then
4478 return Has_Access_Values (Component_Type (Typ));
4480 elsif Is_Record_Type (Typ) then
4485 -- Loop to Check components
4487 Comp := First_Component_Or_Discriminant (Typ);
4488 while Present (Comp) loop
4490 -- Check for access component, tag field does not count, even
4491 -- though it is implemented internally using an access type.
4493 if Has_Access_Values (Etype (Comp))
4494 and then Chars (Comp) /= Name_uTag
4499 Next_Component_Or_Discriminant (Comp);
4508 end Has_Access_Values;
4510 ------------------------------
4511 -- Has_Compatible_Alignment --
4512 ------------------------------
4514 function Has_Compatible_Alignment
4516 Expr : Node_Id) return Alignment_Result
4518 function Has_Compatible_Alignment_Internal
4521 Default : Alignment_Result) return Alignment_Result;
4522 -- This is the internal recursive function that actually does the work.
4523 -- There is one additional parameter, which says what the result should
4524 -- be if no alignment information is found, and there is no definite
4525 -- indication of compatible alignments. At the outer level, this is set
4526 -- to Unknown, but for internal recursive calls in the case where types
4527 -- are known to be correct, it is set to Known_Compatible.
4529 ---------------------------------------
4530 -- Has_Compatible_Alignment_Internal --
4531 ---------------------------------------
4533 function Has_Compatible_Alignment_Internal
4536 Default : Alignment_Result) return Alignment_Result
4538 Result : Alignment_Result := Known_Compatible;
4539 -- Holds the current status of the result. Note that once a value of
4540 -- Known_Incompatible is set, it is sticky and does not get changed
4541 -- to Unknown (the value in Result only gets worse as we go along,
4544 Offs : Uint := No_Uint;
4545 -- Set to a factor of the offset from the base object when Expr is a
4546 -- selected or indexed component, based on Component_Bit_Offset and
4547 -- Component_Size respectively. A negative value is used to represent
4548 -- a value which is not known at compile time.
4550 procedure Check_Prefix;
4551 -- Checks the prefix recursively in the case where the expression
4552 -- is an indexed or selected component.
4554 procedure Set_Result (R : Alignment_Result);
4555 -- If R represents a worse outcome (unknown instead of known
4556 -- compatible, or known incompatible), then set Result to R.
4562 procedure Check_Prefix is
4564 -- The subtlety here is that in doing a recursive call to check
4565 -- the prefix, we have to decide what to do in the case where we
4566 -- don't find any specific indication of an alignment problem.
4568 -- At the outer level, we normally set Unknown as the result in
4569 -- this case, since we can only set Known_Compatible if we really
4570 -- know that the alignment value is OK, but for the recursive
4571 -- call, in the case where the types match, and we have not
4572 -- specified a peculiar alignment for the object, we are only
4573 -- concerned about suspicious rep clauses, the default case does
4574 -- not affect us, since the compiler will, in the absence of such
4575 -- rep clauses, ensure that the alignment is correct.
4577 if Default = Known_Compatible
4579 (Etype (Obj) = Etype (Expr)
4580 and then (Unknown_Alignment (Obj)
4582 Alignment (Obj) = Alignment (Etype (Obj))))
4585 (Has_Compatible_Alignment_Internal
4586 (Obj, Prefix (Expr), Known_Compatible));
4588 -- In all other cases, we need a full check on the prefix
4592 (Has_Compatible_Alignment_Internal
4593 (Obj, Prefix (Expr), Unknown));
4601 procedure Set_Result (R : Alignment_Result) is
4608 -- Start of processing for Has_Compatible_Alignment_Internal
4611 -- If Expr is a selected component, we must make sure there is no
4612 -- potentially troublesome component clause, and that the record is
4615 if Nkind (Expr) = N_Selected_Component then
4617 -- Packed record always generate unknown alignment
4619 if Is_Packed (Etype (Prefix (Expr))) then
4620 Set_Result (Unknown);
4623 -- Check prefix and component offset
4626 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
4628 -- If Expr is an indexed component, we must make sure there is no
4629 -- potentially troublesome Component_Size clause and that the array
4630 -- is not bit-packed.
4632 elsif Nkind (Expr) = N_Indexed_Component then
4634 Typ : constant Entity_Id := Etype (Prefix (Expr));
4635 Ind : constant Node_Id := First_Index (Typ);
4638 -- Bit packed array always generates unknown alignment
4640 if Is_Bit_Packed_Array (Typ) then
4641 Set_Result (Unknown);
4644 -- Check prefix and component offset
4647 Offs := Component_Size (Typ);
4649 -- Small optimization: compute the full offset when possible
4652 and then Offs > Uint_0
4653 and then Present (Ind)
4654 and then Nkind (Ind) = N_Range
4655 and then Compile_Time_Known_Value (Low_Bound (Ind))
4656 and then Compile_Time_Known_Value (First (Expressions (Expr)))
4658 Offs := Offs * (Expr_Value (First (Expressions (Expr)))
4659 - Expr_Value (Low_Bound ((Ind))));
4664 -- If we have a null offset, the result is entirely determined by
4665 -- the base object and has already been computed recursively.
4667 if Offs = Uint_0 then
4670 -- Case where we know the alignment of the object
4672 elsif Known_Alignment (Obj) then
4674 ObjA : constant Uint := Alignment (Obj);
4675 ExpA : Uint := No_Uint;
4676 SizA : Uint := No_Uint;
4679 -- If alignment of Obj is 1, then we are always OK
4682 Set_Result (Known_Compatible);
4684 -- Alignment of Obj is greater than 1, so we need to check
4687 -- If we have an offset, see if it is compatible
4689 if Offs /= No_Uint and Offs > Uint_0 then
4690 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
4691 Set_Result (Known_Incompatible);
4694 -- See if Expr is an object with known alignment
4696 elsif Is_Entity_Name (Expr)
4697 and then Known_Alignment (Entity (Expr))
4699 ExpA := Alignment (Entity (Expr));
4701 -- Otherwise, we can use the alignment of the type of
4702 -- Expr given that we already checked for
4703 -- discombobulating rep clauses for the cases of indexed
4704 -- and selected components above.
4706 elsif Known_Alignment (Etype (Expr)) then
4707 ExpA := Alignment (Etype (Expr));
4709 -- Otherwise the alignment is unknown
4712 Set_Result (Default);
4715 -- If we got an alignment, see if it is acceptable
4717 if ExpA /= No_Uint and then ExpA < ObjA then
4718 Set_Result (Known_Incompatible);
4721 -- If Expr is not a piece of a larger object, see if size
4722 -- is given. If so, check that it is not too small for the
4723 -- required alignment.
4725 if Offs /= No_Uint then
4728 -- See if Expr is an object with known size
4730 elsif Is_Entity_Name (Expr)
4731 and then Known_Static_Esize (Entity (Expr))
4733 SizA := Esize (Entity (Expr));
4735 -- Otherwise, we check the object size of the Expr type
4737 elsif Known_Static_Esize (Etype (Expr)) then
4738 SizA := Esize (Etype (Expr));
4741 -- If we got a size, see if it is a multiple of the Obj
4742 -- alignment, if not, then the alignment cannot be
4743 -- acceptable, since the size is always a multiple of the
4746 if SizA /= No_Uint then
4747 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
4748 Set_Result (Known_Incompatible);
4754 -- If we do not know required alignment, any non-zero offset is a
4755 -- potential problem (but certainly may be OK, so result is unknown).
4757 elsif Offs /= No_Uint then
4758 Set_Result (Unknown);
4760 -- If we can't find the result by direct comparison of alignment
4761 -- values, then there is still one case that we can determine known
4762 -- result, and that is when we can determine that the types are the
4763 -- same, and no alignments are specified. Then we known that the
4764 -- alignments are compatible, even if we don't know the alignment
4765 -- value in the front end.
4767 elsif Etype (Obj) = Etype (Expr) then
4769 -- Types are the same, but we have to check for possible size
4770 -- and alignments on the Expr object that may make the alignment
4771 -- different, even though the types are the same.
4773 if Is_Entity_Name (Expr) then
4775 -- First check alignment of the Expr object. Any alignment less
4776 -- than Maximum_Alignment is worrisome since this is the case
4777 -- where we do not know the alignment of Obj.
4779 if Known_Alignment (Entity (Expr))
4781 UI_To_Int (Alignment (Entity (Expr))) <
4782 Ttypes.Maximum_Alignment
4784 Set_Result (Unknown);
4786 -- Now check size of Expr object. Any size that is not an
4787 -- even multiple of Maximum_Alignment is also worrisome
4788 -- since it may cause the alignment of the object to be less
4789 -- than the alignment of the type.
4791 elsif Known_Static_Esize (Entity (Expr))
4793 (UI_To_Int (Esize (Entity (Expr))) mod
4794 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
4797 Set_Result (Unknown);
4799 -- Otherwise same type is decisive
4802 Set_Result (Known_Compatible);
4806 -- Another case to deal with is when there is an explicit size or
4807 -- alignment clause when the types are not the same. If so, then the
4808 -- result is Unknown. We don't need to do this test if the Default is
4809 -- Unknown, since that result will be set in any case.
4811 elsif Default /= Unknown
4812 and then (Has_Size_Clause (Etype (Expr))
4814 Has_Alignment_Clause (Etype (Expr)))
4816 Set_Result (Unknown);
4818 -- If no indication found, set default
4821 Set_Result (Default);
4824 -- Return worst result found
4827 end Has_Compatible_Alignment_Internal;
4829 -- Start of processing for Has_Compatible_Alignment
4832 -- If Obj has no specified alignment, then set alignment from the type
4833 -- alignment. Perhaps we should always do this, but for sure we should
4834 -- do it when there is an address clause since we can do more if the
4835 -- alignment is known.
4837 if Unknown_Alignment (Obj) then
4838 Set_Alignment (Obj, Alignment (Etype (Obj)));
4841 -- Now do the internal call that does all the work
4843 return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
4844 end Has_Compatible_Alignment;
4846 ----------------------
4847 -- Has_Declarations --
4848 ----------------------
4850 function Has_Declarations (N : Node_Id) return Boolean is
4852 return Nkind_In (Nkind (N), N_Accept_Statement,
4854 N_Compilation_Unit_Aux,
4860 N_Package_Specification);
4861 end Has_Declarations;
4863 -------------------------------------------
4864 -- Has_Discriminant_Dependent_Constraint --
4865 -------------------------------------------
4867 function Has_Discriminant_Dependent_Constraint
4868 (Comp : Entity_Id) return Boolean
4870 Comp_Decl : constant Node_Id := Parent (Comp);
4871 Subt_Indic : constant Node_Id :=
4872 Subtype_Indication (Component_Definition (Comp_Decl));
4877 if Nkind (Subt_Indic) = N_Subtype_Indication then
4878 Constr := Constraint (Subt_Indic);
4880 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
4881 Assn := First (Constraints (Constr));
4882 while Present (Assn) loop
4883 case Nkind (Assn) is
4884 when N_Subtype_Indication |
4888 if Depends_On_Discriminant (Assn) then
4892 when N_Discriminant_Association =>
4893 if Depends_On_Discriminant (Expression (Assn)) then
4908 end Has_Discriminant_Dependent_Constraint;
4910 --------------------
4911 -- Has_Infinities --
4912 --------------------
4914 function Has_Infinities (E : Entity_Id) return Boolean is
4917 Is_Floating_Point_Type (E)
4918 and then Nkind (Scalar_Range (E)) = N_Range
4919 and then Includes_Infinities (Scalar_Range (E));
4922 --------------------
4923 -- Has_Interfaces --
4924 --------------------
4926 function Has_Interfaces
4928 Use_Full_View : Boolean := True) return Boolean
4930 Typ : Entity_Id := Base_Type (T);
4933 -- Handle concurrent types
4935 if Is_Concurrent_Type (Typ) then
4936 Typ := Corresponding_Record_Type (Typ);
4939 if not Present (Typ)
4940 or else not Is_Record_Type (Typ)
4941 or else not Is_Tagged_Type (Typ)
4946 -- Handle private types
4949 and then Present (Full_View (Typ))
4951 Typ := Full_View (Typ);
4954 -- Handle concurrent record types
4956 if Is_Concurrent_Record_Type (Typ)
4957 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
4963 if Is_Interface (Typ)
4965 (Is_Record_Type (Typ)
4966 and then Present (Interfaces (Typ))
4967 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
4972 exit when Etype (Typ) = Typ
4974 -- Handle private types
4976 or else (Present (Full_View (Etype (Typ)))
4977 and then Full_View (Etype (Typ)) = Typ)
4979 -- Protect the frontend against wrong source with cyclic
4982 or else Etype (Typ) = T;
4984 -- Climb to the ancestor type handling private types
4986 if Present (Full_View (Etype (Typ))) then
4987 Typ := Full_View (Etype (Typ));
4996 ------------------------
4997 -- Has_Null_Exclusion --
4998 ------------------------
5000 function Has_Null_Exclusion (N : Node_Id) return Boolean is
5003 when N_Access_Definition |
5004 N_Access_Function_Definition |
5005 N_Access_Procedure_Definition |
5006 N_Access_To_Object_Definition |
5008 N_Derived_Type_Definition |
5009 N_Function_Specification |
5010 N_Subtype_Declaration =>
5011 return Null_Exclusion_Present (N);
5013 when N_Component_Definition |
5014 N_Formal_Object_Declaration |
5015 N_Object_Renaming_Declaration =>
5016 if Present (Subtype_Mark (N)) then
5017 return Null_Exclusion_Present (N);
5018 else pragma Assert (Present (Access_Definition (N)));
5019 return Null_Exclusion_Present (Access_Definition (N));
5022 when N_Discriminant_Specification =>
5023 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
5024 return Null_Exclusion_Present (Discriminant_Type (N));
5026 return Null_Exclusion_Present (N);
5029 when N_Object_Declaration =>
5030 if Nkind (Object_Definition (N)) = N_Access_Definition then
5031 return Null_Exclusion_Present (Object_Definition (N));
5033 return Null_Exclusion_Present (N);
5036 when N_Parameter_Specification =>
5037 if Nkind (Parameter_Type (N)) = N_Access_Definition then
5038 return Null_Exclusion_Present (Parameter_Type (N));
5040 return Null_Exclusion_Present (N);
5047 end Has_Null_Exclusion;
5049 ------------------------
5050 -- Has_Null_Extension --
5051 ------------------------
5053 function Has_Null_Extension (T : Entity_Id) return Boolean is
5054 B : constant Entity_Id := Base_Type (T);
5059 if Nkind (Parent (B)) = N_Full_Type_Declaration
5060 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
5062 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
5064 if Present (Ext) then
5065 if Null_Present (Ext) then
5068 Comps := Component_List (Ext);
5070 -- The null component list is rewritten during analysis to
5071 -- include the parent component. Any other component indicates
5072 -- that the extension was not originally null.
5074 return Null_Present (Comps)
5075 or else No (Next (First (Component_Items (Comps))));
5084 end Has_Null_Extension;
5086 -------------------------------
5087 -- Has_Overriding_Initialize --
5088 -------------------------------
5090 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
5091 BT : constant Entity_Id := Base_Type (T);
5095 if Is_Controlled (BT) then
5096 if Is_RTU (Scope (BT), Ada_Finalization) then
5099 elsif Present (Primitive_Operations (BT)) then
5100 P := First_Elmt (Primitive_Operations (BT));
5101 while Present (P) loop
5103 Init : constant Entity_Id := Node (P);
5104 Formal : constant Entity_Id := First_Formal (Init);
5106 if Ekind (Init) = E_Procedure
5107 and then Chars (Init) = Name_Initialize
5108 and then Comes_From_Source (Init)
5109 and then Present (Formal)
5110 and then Etype (Formal) = BT
5111 and then No (Next_Formal (Formal))
5112 and then (Ada_Version < Ada_2012
5113 or else not Null_Present (Parent (Init)))
5123 -- Here if type itself does not have a non-null Initialize operation:
5124 -- check immediate ancestor.
5126 if Is_Derived_Type (BT)
5127 and then Has_Overriding_Initialize (Etype (BT))
5134 end Has_Overriding_Initialize;
5136 --------------------------------------
5137 -- Has_Preelaborable_Initialization --
5138 --------------------------------------
5140 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
5143 procedure Check_Components (E : Entity_Id);
5144 -- Check component/discriminant chain, sets Has_PE False if a component
5145 -- or discriminant does not meet the preelaborable initialization rules.
5147 ----------------------
5148 -- Check_Components --
5149 ----------------------
5151 procedure Check_Components (E : Entity_Id) is
5155 function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
5156 -- Returns True if and only if the expression denoted by N does not
5157 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
5159 ---------------------------------
5160 -- Is_Preelaborable_Expression --
5161 ---------------------------------
5163 function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
5167 Comp_Type : Entity_Id;
5168 Is_Array_Aggr : Boolean;
5171 if Is_Static_Expression (N) then
5174 elsif Nkind (N) = N_Null then
5177 -- Attributes are allowed in general, even if their prefix is a
5178 -- formal type. (It seems that certain attributes known not to be
5179 -- static might not be allowed, but there are no rules to prevent
5182 elsif Nkind (N) = N_Attribute_Reference then
5185 -- The name of a discriminant evaluated within its parent type is
5186 -- defined to be preelaborable (10.2.1(8)). Note that we test for
5187 -- names that denote discriminals as well as discriminants to
5188 -- catch references occurring within init procs.
5190 elsif Is_Entity_Name (N)
5192 (Ekind (Entity (N)) = E_Discriminant
5194 ((Ekind (Entity (N)) = E_Constant
5195 or else Ekind (Entity (N)) = E_In_Parameter)
5196 and then Present (Discriminal_Link (Entity (N)))))
5200 elsif Nkind (N) = N_Qualified_Expression then
5201 return Is_Preelaborable_Expression (Expression (N));
5203 -- For aggregates we have to check that each of the associations
5204 -- is preelaborable.
5206 elsif Nkind (N) = N_Aggregate
5207 or else Nkind (N) = N_Extension_Aggregate
5209 Is_Array_Aggr := Is_Array_Type (Etype (N));
5211 if Is_Array_Aggr then
5212 Comp_Type := Component_Type (Etype (N));
5215 -- Check the ancestor part of extension aggregates, which must
5216 -- be either the name of a type that has preelaborable init or
5217 -- an expression that is preelaborable.
5219 if Nkind (N) = N_Extension_Aggregate then
5221 Anc_Part : constant Node_Id := Ancestor_Part (N);
5224 if Is_Entity_Name (Anc_Part)
5225 and then Is_Type (Entity (Anc_Part))
5227 if not Has_Preelaborable_Initialization
5233 elsif not Is_Preelaborable_Expression (Anc_Part) then
5239 -- Check positional associations
5241 Exp := First (Expressions (N));
5242 while Present (Exp) loop
5243 if not Is_Preelaborable_Expression (Exp) then
5250 -- Check named associations
5252 Assn := First (Component_Associations (N));
5253 while Present (Assn) loop
5254 Choice := First (Choices (Assn));
5255 while Present (Choice) loop
5256 if Is_Array_Aggr then
5257 if Nkind (Choice) = N_Others_Choice then
5260 elsif Nkind (Choice) = N_Range then
5261 if not Is_Static_Range (Choice) then
5265 elsif not Is_Static_Expression (Choice) then
5270 Comp_Type := Etype (Choice);
5276 -- If the association has a <> at this point, then we have
5277 -- to check whether the component's type has preelaborable
5278 -- initialization. Note that this only occurs when the
5279 -- association's corresponding component does not have a
5280 -- default expression, the latter case having already been
5281 -- expanded as an expression for the association.
5283 if Box_Present (Assn) then
5284 if not Has_Preelaborable_Initialization (Comp_Type) then
5288 -- In the expression case we check whether the expression
5289 -- is preelaborable.
5292 not Is_Preelaborable_Expression (Expression (Assn))
5300 -- If we get here then aggregate as a whole is preelaborable
5304 -- All other cases are not preelaborable
5309 end Is_Preelaborable_Expression;
5311 -- Start of processing for Check_Components
5314 -- Loop through entities of record or protected type
5317 while Present (Ent) loop
5319 -- We are interested only in components and discriminants
5326 -- Get default expression if any. If there is no declaration
5327 -- node, it means we have an internal entity. The parent and
5328 -- tag fields are examples of such entities. For such cases,
5329 -- we just test the type of the entity.
5331 if Present (Declaration_Node (Ent)) then
5332 Exp := Expression (Declaration_Node (Ent));
5335 when E_Discriminant =>
5337 -- Note: for a renamed discriminant, the Declaration_Node
5338 -- may point to the one from the ancestor, and have a
5339 -- different expression, so use the proper attribute to
5340 -- retrieve the expression from the derived constraint.
5342 Exp := Discriminant_Default_Value (Ent);
5345 goto Check_Next_Entity;
5348 -- A component has PI if it has no default expression and the
5349 -- component type has PI.
5352 if not Has_Preelaborable_Initialization (Etype (Ent)) then
5357 -- Require the default expression to be preelaborable
5359 elsif not Is_Preelaborable_Expression (Exp) then
5364 <<Check_Next_Entity>>
5367 end Check_Components;
5369 -- Start of processing for Has_Preelaborable_Initialization
5372 -- Immediate return if already marked as known preelaborable init. This
5373 -- covers types for which this function has already been called once
5374 -- and returned True (in which case the result is cached), and also
5375 -- types to which a pragma Preelaborable_Initialization applies.
5377 if Known_To_Have_Preelab_Init (E) then
5381 -- If the type is a subtype representing a generic actual type, then
5382 -- test whether its base type has preelaborable initialization since
5383 -- the subtype representing the actual does not inherit this attribute
5384 -- from the actual or formal. (but maybe it should???)
5386 if Is_Generic_Actual_Type (E) then
5387 return Has_Preelaborable_Initialization (Base_Type (E));
5390 -- All elementary types have preelaborable initialization
5392 if Is_Elementary_Type (E) then
5395 -- Array types have PI if the component type has PI
5397 elsif Is_Array_Type (E) then
5398 Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
5400 -- A derived type has preelaborable initialization if its parent type
5401 -- has preelaborable initialization and (in the case of a derived record
5402 -- extension) if the non-inherited components all have preelaborable
5403 -- initialization. However, a user-defined controlled type with an
5404 -- overriding Initialize procedure does not have preelaborable
5407 elsif Is_Derived_Type (E) then
5409 -- If the derived type is a private extension then it doesn't have
5410 -- preelaborable initialization.
5412 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
5416 -- First check whether ancestor type has preelaborable initialization
5418 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
5420 -- If OK, check extension components (if any)
5422 if Has_PE and then Is_Record_Type (E) then
5423 Check_Components (First_Entity (E));
5426 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
5427 -- with a user defined Initialize procedure does not have PI.
5430 and then Is_Controlled (E)
5431 and then Has_Overriding_Initialize (E)
5436 -- Private types not derived from a type having preelaborable init and
5437 -- that are not marked with pragma Preelaborable_Initialization do not
5438 -- have preelaborable initialization.
5440 elsif Is_Private_Type (E) then
5443 -- Record type has PI if it is non private and all components have PI
5445 elsif Is_Record_Type (E) then
5447 Check_Components (First_Entity (E));
5449 -- Protected types must not have entries, and components must meet
5450 -- same set of rules as for record components.
5452 elsif Is_Protected_Type (E) then
5453 if Has_Entries (E) then
5457 Check_Components (First_Entity (E));
5458 Check_Components (First_Private_Entity (E));
5461 -- Type System.Address always has preelaborable initialization
5463 elsif Is_RTE (E, RE_Address) then
5466 -- In all other cases, type does not have preelaborable initialization
5472 -- If type has preelaborable initialization, cache result
5475 Set_Known_To_Have_Preelab_Init (E);
5479 end Has_Preelaborable_Initialization;
5481 ---------------------------
5482 -- Has_Private_Component --
5483 ---------------------------
5485 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
5486 Btype : Entity_Id := Base_Type (Type_Id);
5487 Component : Entity_Id;
5490 if Error_Posted (Type_Id)
5491 or else Error_Posted (Btype)
5496 if Is_Class_Wide_Type (Btype) then
5497 Btype := Root_Type (Btype);
5500 if Is_Private_Type (Btype) then
5502 UT : constant Entity_Id := Underlying_Type (Btype);
5505 if No (Full_View (Btype)) then
5506 return not Is_Generic_Type (Btype)
5507 and then not Is_Generic_Type (Root_Type (Btype));
5509 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
5512 return not Is_Frozen (UT) and then Has_Private_Component (UT);
5516 elsif Is_Array_Type (Btype) then
5517 return Has_Private_Component (Component_Type (Btype));
5519 elsif Is_Record_Type (Btype) then
5520 Component := First_Component (Btype);
5521 while Present (Component) loop
5522 if Has_Private_Component (Etype (Component)) then
5526 Next_Component (Component);
5531 elsif Is_Protected_Type (Btype)
5532 and then Present (Corresponding_Record_Type (Btype))
5534 return Has_Private_Component (Corresponding_Record_Type (Btype));
5539 end Has_Private_Component;
5545 function Has_Stream (T : Entity_Id) return Boolean is
5552 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
5555 elsif Is_Array_Type (T) then
5556 return Has_Stream (Component_Type (T));
5558 elsif Is_Record_Type (T) then
5559 E := First_Component (T);
5560 while Present (E) loop
5561 if Has_Stream (Etype (E)) then
5570 elsif Is_Private_Type (T) then
5571 return Has_Stream (Underlying_Type (T));
5582 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
5584 Get_Name_String (Chars (E));
5585 return Name_Buffer (Name_Len) = Suffix;
5588 --------------------------
5589 -- Has_Tagged_Component --
5590 --------------------------
5592 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
5596 if Is_Private_Type (Typ)
5597 and then Present (Underlying_Type (Typ))
5599 return Has_Tagged_Component (Underlying_Type (Typ));
5601 elsif Is_Array_Type (Typ) then
5602 return Has_Tagged_Component (Component_Type (Typ));
5604 elsif Is_Tagged_Type (Typ) then
5607 elsif Is_Record_Type (Typ) then
5608 Comp := First_Component (Typ);
5609 while Present (Comp) loop
5610 if Has_Tagged_Component (Etype (Comp)) then
5614 Next_Component (Comp);
5622 end Has_Tagged_Component;
5624 -------------------------
5625 -- Implementation_Kind --
5626 -------------------------
5628 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
5629 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
5631 pragma Assert (Present (Impl_Prag));
5633 Chars (Expression (Last (Pragma_Argument_Associations (Impl_Prag))));
5634 end Implementation_Kind;
5636 --------------------------
5637 -- Implements_Interface --
5638 --------------------------
5640 function Implements_Interface
5641 (Typ_Ent : Entity_Id;
5642 Iface_Ent : Entity_Id;
5643 Exclude_Parents : Boolean := False) return Boolean
5645 Ifaces_List : Elist_Id;
5647 Iface : Entity_Id := Base_Type (Iface_Ent);
5648 Typ : Entity_Id := Base_Type (Typ_Ent);
5651 if Is_Class_Wide_Type (Typ) then
5652 Typ := Root_Type (Typ);
5655 if not Has_Interfaces (Typ) then
5659 if Is_Class_Wide_Type (Iface) then
5660 Iface := Root_Type (Iface);
5663 Collect_Interfaces (Typ, Ifaces_List);
5665 Elmt := First_Elmt (Ifaces_List);
5666 while Present (Elmt) loop
5667 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
5668 and then Exclude_Parents
5672 elsif Node (Elmt) = Iface then
5680 end Implements_Interface;
5686 function In_Instance return Boolean is
5687 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
5693 and then S /= Standard_Standard
5695 if (Ekind (S) = E_Function
5696 or else Ekind (S) = E_Package
5697 or else Ekind (S) = E_Procedure)
5698 and then Is_Generic_Instance (S)
5700 -- A child instance is always compiled in the context of a parent
5701 -- instance. Nevertheless, the actuals are not analyzed in an
5702 -- instance context. We detect this case by examining the current
5703 -- compilation unit, which must be a child instance, and checking
5704 -- that it is not currently on the scope stack.
5706 if Is_Child_Unit (Curr_Unit)
5708 Nkind (Unit (Cunit (Current_Sem_Unit)))
5709 = N_Package_Instantiation
5710 and then not In_Open_Scopes (Curr_Unit)
5724 ----------------------
5725 -- In_Instance_Body --
5726 ----------------------
5728 function In_Instance_Body return Boolean is
5734 and then S /= Standard_Standard
5736 if (Ekind (S) = E_Function
5737 or else Ekind (S) = E_Procedure)
5738 and then Is_Generic_Instance (S)
5742 elsif Ekind (S) = E_Package
5743 and then In_Package_Body (S)
5744 and then Is_Generic_Instance (S)
5753 end In_Instance_Body;
5755 -----------------------------
5756 -- In_Instance_Not_Visible --
5757 -----------------------------
5759 function In_Instance_Not_Visible return Boolean is
5765 and then S /= Standard_Standard
5767 if (Ekind (S) = E_Function
5768 or else Ekind (S) = E_Procedure)
5769 and then Is_Generic_Instance (S)
5773 elsif Ekind (S) = E_Package
5774 and then (In_Package_Body (S) or else In_Private_Part (S))
5775 and then Is_Generic_Instance (S)
5784 end In_Instance_Not_Visible;
5786 ------------------------------
5787 -- In_Instance_Visible_Part --
5788 ------------------------------
5790 function In_Instance_Visible_Part return Boolean is
5796 and then S /= Standard_Standard
5798 if Ekind (S) = E_Package
5799 and then Is_Generic_Instance (S)
5800 and then not In_Package_Body (S)
5801 and then not In_Private_Part (S)
5810 end In_Instance_Visible_Part;
5812 ---------------------
5813 -- In_Package_Body --
5814 ---------------------
5816 function In_Package_Body return Boolean is
5822 and then S /= Standard_Standard
5824 if Ekind (S) = E_Package
5825 and then In_Package_Body (S)
5834 end In_Package_Body;
5836 --------------------------------
5837 -- In_Parameter_Specification --
5838 --------------------------------
5840 function In_Parameter_Specification (N : Node_Id) return Boolean is
5845 while Present (PN) loop
5846 if Nkind (PN) = N_Parameter_Specification then
5854 end In_Parameter_Specification;
5856 --------------------------------------
5857 -- In_Subprogram_Or_Concurrent_Unit --
5858 --------------------------------------
5860 function In_Subprogram_Or_Concurrent_Unit return Boolean is
5865 -- Use scope chain to check successively outer scopes
5871 if K in Subprogram_Kind
5872 or else K in Concurrent_Kind
5873 or else K in Generic_Subprogram_Kind
5877 elsif E = Standard_Standard then
5883 end In_Subprogram_Or_Concurrent_Unit;
5885 ---------------------
5886 -- In_Visible_Part --
5887 ---------------------
5889 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
5892 Is_Package_Or_Generic_Package (Scope_Id)
5893 and then In_Open_Scopes (Scope_Id)
5894 and then not In_Package_Body (Scope_Id)
5895 and then not In_Private_Part (Scope_Id);
5896 end In_Visible_Part;
5898 ---------------------------------
5899 -- Insert_Explicit_Dereference --
5900 ---------------------------------
5902 procedure Insert_Explicit_Dereference (N : Node_Id) is
5903 New_Prefix : constant Node_Id := Relocate_Node (N);
5904 Ent : Entity_Id := Empty;
5911 Save_Interps (N, New_Prefix);
5914 Make_Explicit_Dereference (Sloc (Parent (N)),
5915 Prefix => New_Prefix));
5917 Set_Etype (N, Designated_Type (Etype (New_Prefix)));
5919 if Is_Overloaded (New_Prefix) then
5921 -- The dereference is also overloaded, and its interpretations are
5922 -- the designated types of the interpretations of the original node.
5924 Set_Etype (N, Any_Type);
5926 Get_First_Interp (New_Prefix, I, It);
5927 while Present (It.Nam) loop
5930 if Is_Access_Type (T) then
5931 Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
5934 Get_Next_Interp (I, It);
5940 -- Prefix is unambiguous: mark the original prefix (which might
5941 -- Come_From_Source) as a reference, since the new (relocated) one
5942 -- won't be taken into account.
5944 if Is_Entity_Name (New_Prefix) then
5945 Ent := Entity (New_Prefix);
5948 -- For a retrieval of a subcomponent of some composite object,
5949 -- retrieve the ultimate entity if there is one.
5951 elsif Nkind (New_Prefix) = N_Selected_Component
5952 or else Nkind (New_Prefix) = N_Indexed_Component
5954 Pref := Prefix (New_Prefix);
5955 while Present (Pref)
5957 (Nkind (Pref) = N_Selected_Component
5958 or else Nkind (Pref) = N_Indexed_Component)
5960 Pref := Prefix (Pref);
5963 if Present (Pref) and then Is_Entity_Name (Pref) then
5964 Ent := Entity (Pref);
5968 -- Place the reference on the entity node
5970 if Present (Ent) then
5971 Generate_Reference (Ent, Pref);
5974 end Insert_Explicit_Dereference;
5976 ------------------------------------------
5977 -- Inspect_Deferred_Constant_Completion --
5978 ------------------------------------------
5980 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
5984 Decl := First (Decls);
5985 while Present (Decl) loop
5987 -- Deferred constant signature
5989 if Nkind (Decl) = N_Object_Declaration
5990 and then Constant_Present (Decl)
5991 and then No (Expression (Decl))
5993 -- No need to check internally generated constants
5995 and then Comes_From_Source (Decl)
5997 -- The constant is not completed. A full object declaration or a
5998 -- pragma Import complete a deferred constant.
6000 and then not Has_Completion (Defining_Identifier (Decl))
6003 ("constant declaration requires initialization expression",
6004 Defining_Identifier (Decl));
6007 Decl := Next (Decl);
6009 end Inspect_Deferred_Constant_Completion;
6011 -----------------------------
6012 -- Is_Actual_Out_Parameter --
6013 -----------------------------
6015 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
6019 Find_Actual (N, Formal, Call);
6020 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
6021 end Is_Actual_Out_Parameter;
6023 -------------------------
6024 -- Is_Actual_Parameter --
6025 -------------------------
6027 function Is_Actual_Parameter (N : Node_Id) return Boolean is
6028 PK : constant Node_Kind := Nkind (Parent (N));
6032 when N_Parameter_Association =>
6033 return N = Explicit_Actual_Parameter (Parent (N));
6035 when N_Function_Call | N_Procedure_Call_Statement =>
6036 return Is_List_Member (N)
6038 List_Containing (N) = Parameter_Associations (Parent (N));
6043 end Is_Actual_Parameter;
6045 --------------------------------
6046 -- Is_Actual_Tagged_Parameter --
6047 --------------------------------
6049 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
6053 Find_Actual (N, Formal, Call);
6054 return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
6055 end Is_Actual_Tagged_Parameter;
6057 ---------------------
6058 -- Is_Aliased_View --
6059 ---------------------
6061 function Is_Aliased_View (Obj : Node_Id) return Boolean is
6065 if Is_Entity_Name (Obj) then
6073 or else (Present (Renamed_Object (E))
6074 and then Is_Aliased_View (Renamed_Object (E)))))
6076 or else ((Is_Formal (E)
6077 or else Ekind (E) = E_Generic_In_Out_Parameter
6078 or else Ekind (E) = E_Generic_In_Parameter)
6079 and then Is_Tagged_Type (Etype (E)))
6081 or else (Is_Concurrent_Type (E)
6082 and then In_Open_Scopes (E))
6084 -- Current instance of type, either directly or as rewritten
6085 -- reference to the current object.
6087 or else (Is_Entity_Name (Original_Node (Obj))
6088 and then Present (Entity (Original_Node (Obj)))
6089 and then Is_Type (Entity (Original_Node (Obj))))
6091 or else (Is_Type (E) and then E = Current_Scope)
6093 or else (Is_Incomplete_Or_Private_Type (E)
6094 and then Full_View (E) = Current_Scope);
6096 elsif Nkind (Obj) = N_Selected_Component then
6097 return Is_Aliased (Entity (Selector_Name (Obj)));
6099 elsif Nkind (Obj) = N_Indexed_Component then
6100 return Has_Aliased_Components (Etype (Prefix (Obj)))
6102 (Is_Access_Type (Etype (Prefix (Obj)))
6104 Has_Aliased_Components
6105 (Designated_Type (Etype (Prefix (Obj)))));
6107 elsif Nkind (Obj) = N_Unchecked_Type_Conversion
6108 or else Nkind (Obj) = N_Type_Conversion
6110 return Is_Tagged_Type (Etype (Obj))
6111 and then Is_Aliased_View (Expression (Obj));
6113 elsif Nkind (Obj) = N_Explicit_Dereference then
6114 return Nkind (Original_Node (Obj)) /= N_Function_Call;
6119 end Is_Aliased_View;
6121 -------------------------
6122 -- Is_Ancestor_Package --
6123 -------------------------
6125 function Is_Ancestor_Package
6127 E2 : Entity_Id) return Boolean
6134 and then Par /= Standard_Standard
6144 end Is_Ancestor_Package;
6146 ----------------------
6147 -- Is_Atomic_Object --
6148 ----------------------
6150 function Is_Atomic_Object (N : Node_Id) return Boolean is
6152 function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
6153 -- Determines if given object has atomic components
6155 function Is_Atomic_Prefix (N : Node_Id) return Boolean;
6156 -- If prefix is an implicit dereference, examine designated type
6158 ----------------------
6159 -- Is_Atomic_Prefix --
6160 ----------------------
6162 function Is_Atomic_Prefix (N : Node_Id) return Boolean is
6164 if Is_Access_Type (Etype (N)) then
6166 Has_Atomic_Components (Designated_Type (Etype (N)));
6168 return Object_Has_Atomic_Components (N);
6170 end Is_Atomic_Prefix;
6172 ----------------------------------
6173 -- Object_Has_Atomic_Components --
6174 ----------------------------------
6176 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
6178 if Has_Atomic_Components (Etype (N))
6179 or else Is_Atomic (Etype (N))
6183 elsif Is_Entity_Name (N)
6184 and then (Has_Atomic_Components (Entity (N))
6185 or else Is_Atomic (Entity (N)))
6189 elsif Nkind (N) = N_Indexed_Component
6190 or else Nkind (N) = N_Selected_Component
6192 return Is_Atomic_Prefix (Prefix (N));
6197 end Object_Has_Atomic_Components;
6199 -- Start of processing for Is_Atomic_Object
6202 -- Predicate is not relevant to subprograms
6204 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
6207 elsif Is_Atomic (Etype (N))
6208 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
6212 elsif Nkind (N) = N_Indexed_Component
6213 or else Nkind (N) = N_Selected_Component
6215 return Is_Atomic_Prefix (Prefix (N));
6220 end Is_Atomic_Object;
6222 -------------------------
6223 -- Is_Coextension_Root --
6224 -------------------------
6226 function Is_Coextension_Root (N : Node_Id) return Boolean is
6229 Nkind (N) = N_Allocator
6230 and then Present (Coextensions (N))
6232 -- Anonymous access discriminants carry a list of all nested
6233 -- controlled coextensions.
6235 and then not Is_Dynamic_Coextension (N)
6236 and then not Is_Static_Coextension (N);
6237 end Is_Coextension_Root;
6239 -----------------------------
6240 -- Is_Concurrent_Interface --
6241 -----------------------------
6243 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
6248 (Is_Protected_Interface (T)
6249 or else Is_Synchronized_Interface (T)
6250 or else Is_Task_Interface (T));
6251 end Is_Concurrent_Interface;
6253 --------------------------------------
6254 -- Is_Controlling_Limited_Procedure --
6255 --------------------------------------
6257 function Is_Controlling_Limited_Procedure
6258 (Proc_Nam : Entity_Id) return Boolean
6260 Param_Typ : Entity_Id := Empty;
6263 if Ekind (Proc_Nam) = E_Procedure
6264 and then Present (Parameter_Specifications (Parent (Proc_Nam)))
6266 Param_Typ := Etype (Parameter_Type (First (
6267 Parameter_Specifications (Parent (Proc_Nam)))));
6269 -- In this case where an Itype was created, the procedure call has been
6272 elsif Present (Associated_Node_For_Itype (Proc_Nam))
6273 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
6275 Present (Parameter_Associations
6276 (Associated_Node_For_Itype (Proc_Nam)))
6279 Etype (First (Parameter_Associations
6280 (Associated_Node_For_Itype (Proc_Nam))));
6283 if Present (Param_Typ) then
6285 Is_Interface (Param_Typ)
6286 and then Is_Limited_Record (Param_Typ);
6290 end Is_Controlling_Limited_Procedure;
6292 -----------------------------
6293 -- Is_CPP_Constructor_Call --
6294 -----------------------------
6296 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
6298 return Nkind (N) = N_Function_Call
6299 and then Is_CPP_Class (Etype (Etype (N)))
6300 and then Is_Constructor (Entity (Name (N)))
6301 and then Is_Imported (Entity (Name (N)));
6302 end Is_CPP_Constructor_Call;
6308 function Is_Delegate (T : Entity_Id) return Boolean is
6309 Desig_Type : Entity_Id;
6312 if VM_Target /= CLI_Target then
6316 -- Access-to-subprograms are delegates in CIL
6318 if Ekind (T) = E_Access_Subprogram_Type then
6322 if Ekind (T) not in Access_Kind then
6324 -- A delegate is a managed pointer. If no designated type is defined
6325 -- it means that it's not a delegate.
6330 Desig_Type := Etype (Directly_Designated_Type (T));
6332 if not Is_Tagged_Type (Desig_Type) then
6336 -- Test if the type is inherited from [mscorlib]System.Delegate
6338 while Etype (Desig_Type) /= Desig_Type loop
6339 if Chars (Scope (Desig_Type)) /= No_Name
6340 and then Is_Imported (Scope (Desig_Type))
6341 and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
6346 Desig_Type := Etype (Desig_Type);
6352 ----------------------------------------------
6353 -- Is_Dependent_Component_Of_Mutable_Object --
6354 ----------------------------------------------
6356 function Is_Dependent_Component_Of_Mutable_Object
6357 (Object : Node_Id) return Boolean
6360 Prefix_Type : Entity_Id;
6361 P_Aliased : Boolean := False;
6364 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
6365 -- Returns True if and only if Comp is declared within a variant part
6367 --------------------------------
6368 -- Is_Declared_Within_Variant --
6369 --------------------------------
6371 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
6372 Comp_Decl : constant Node_Id := Parent (Comp);
6373 Comp_List : constant Node_Id := Parent (Comp_Decl);
6375 return Nkind (Parent (Comp_List)) = N_Variant;
6376 end Is_Declared_Within_Variant;
6378 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
6381 if Is_Variable (Object) then
6383 if Nkind (Object) = N_Selected_Component then
6384 P := Prefix (Object);
6385 Prefix_Type := Etype (P);
6387 if Is_Entity_Name (P) then
6389 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
6390 Prefix_Type := Base_Type (Prefix_Type);
6393 if Is_Aliased (Entity (P)) then
6397 -- A discriminant check on a selected component may be expanded
6398 -- into a dereference when removing side-effects. Recover the
6399 -- original node and its type, which may be unconstrained.
6401 elsif Nkind (P) = N_Explicit_Dereference
6402 and then not (Comes_From_Source (P))
6404 P := Original_Node (P);
6405 Prefix_Type := Etype (P);
6408 -- Check for prefix being an aliased component???
6414 -- A heap object is constrained by its initial value
6416 -- Ada 2005 (AI-363): Always assume the object could be mutable in
6417 -- the dereferenced case, since the access value might denote an
6418 -- unconstrained aliased object, whereas in Ada 95 the designated
6419 -- object is guaranteed to be constrained. A worst-case assumption
6420 -- has to apply in Ada 2005 because we can't tell at compile time
6421 -- whether the object is "constrained by its initial value"
6422 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
6423 -- semantic rules -- these rules are acknowledged to need fixing).
6425 if Ada_Version < Ada_2005 then
6426 if Is_Access_Type (Prefix_Type)
6427 or else Nkind (P) = N_Explicit_Dereference
6432 elsif Ada_Version >= Ada_2005 then
6433 if Is_Access_Type (Prefix_Type) then
6435 -- If the access type is pool-specific, and there is no
6436 -- constrained partial view of the designated type, then the
6437 -- designated object is known to be constrained.
6439 if Ekind (Prefix_Type) = E_Access_Type
6440 and then not Has_Constrained_Partial_View
6441 (Designated_Type (Prefix_Type))
6445 -- Otherwise (general access type, or there is a constrained
6446 -- partial view of the designated type), we need to check
6447 -- based on the designated type.
6450 Prefix_Type := Designated_Type (Prefix_Type);
6456 Original_Record_Component (Entity (Selector_Name (Object)));
6458 -- As per AI-0017, the renaming is illegal in a generic body, even
6459 -- if the subtype is indefinite.
6461 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
6463 if not Is_Constrained (Prefix_Type)
6464 and then (not Is_Indefinite_Subtype (Prefix_Type)
6466 (Is_Generic_Type (Prefix_Type)
6467 and then Ekind (Current_Scope) = E_Generic_Package
6468 and then In_Package_Body (Current_Scope)))
6470 and then (Is_Declared_Within_Variant (Comp)
6471 or else Has_Discriminant_Dependent_Constraint (Comp))
6472 and then (not P_Aliased or else Ada_Version >= Ada_2005)
6478 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
6482 elsif Nkind (Object) = N_Indexed_Component
6483 or else Nkind (Object) = N_Slice
6485 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
6487 -- A type conversion that Is_Variable is a view conversion:
6488 -- go back to the denoted object.
6490 elsif Nkind (Object) = N_Type_Conversion then
6492 Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
6497 end Is_Dependent_Component_Of_Mutable_Object;
6499 ---------------------
6500 -- Is_Dereferenced --
6501 ---------------------
6503 function Is_Dereferenced (N : Node_Id) return Boolean is
6504 P : constant Node_Id := Parent (N);
6507 (Nkind (P) = N_Selected_Component
6509 Nkind (P) = N_Explicit_Dereference
6511 Nkind (P) = N_Indexed_Component
6513 Nkind (P) = N_Slice)
6514 and then Prefix (P) = N;
6515 end Is_Dereferenced;
6517 ----------------------
6518 -- Is_Descendent_Of --
6519 ----------------------
6521 function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
6526 pragma Assert (Nkind (T1) in N_Entity);
6527 pragma Assert (Nkind (T2) in N_Entity);
6529 T := Base_Type (T1);
6531 -- Immediate return if the types match
6536 -- Comment needed here ???
6538 elsif Ekind (T) = E_Class_Wide_Type then
6539 return Etype (T) = T2;
6547 -- Done if we found the type we are looking for
6552 -- Done if no more derivations to check
6559 -- Following test catches error cases resulting from prev errors
6561 elsif No (Etyp) then
6564 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
6567 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
6571 T := Base_Type (Etyp);
6574 end Is_Descendent_Of;
6576 ----------------------------
6577 -- Is_Expression_Function --
6578 ----------------------------
6580 function Is_Expression_Function (Subp : Entity_Id) return Boolean is
6581 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
6584 return Ekind (Subp) = E_Function
6585 and then Nkind (Decl) = N_Subprogram_Declaration
6587 (Nkind (Original_Node (Decl)) = N_Expression_Function
6589 (Present (Corresponding_Body (Decl))
6591 Nkind (Original_Node
6592 (Unit_Declaration_Node (Corresponding_Body (Decl))))
6593 = N_Expression_Function));
6594 end Is_Expression_Function;
6600 function Is_False (U : Uint) return Boolean is
6605 ---------------------------
6606 -- Is_Fixed_Model_Number --
6607 ---------------------------
6609 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
6610 S : constant Ureal := Small_Value (T);
6611 M : Urealp.Save_Mark;
6615 R := (U = UR_Trunc (U / S) * S);
6618 end Is_Fixed_Model_Number;
6620 -------------------------------
6621 -- Is_Fully_Initialized_Type --
6622 -------------------------------
6624 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
6626 if Is_Scalar_Type (Typ) then
6629 elsif Is_Access_Type (Typ) then
6632 elsif Is_Array_Type (Typ) then
6633 if Is_Fully_Initialized_Type (Component_Type (Typ)) then
6637 -- An interesting case, if we have a constrained type one of whose
6638 -- bounds is known to be null, then there are no elements to be
6639 -- initialized, so all the elements are initialized!
6641 if Is_Constrained (Typ) then
6644 Indx_Typ : Entity_Id;
6648 Indx := First_Index (Typ);
6649 while Present (Indx) loop
6650 if Etype (Indx) = Any_Type then
6653 -- If index is a range, use directly
6655 elsif Nkind (Indx) = N_Range then
6656 Lbd := Low_Bound (Indx);
6657 Hbd := High_Bound (Indx);
6660 Indx_Typ := Etype (Indx);
6662 if Is_Private_Type (Indx_Typ) then
6663 Indx_Typ := Full_View (Indx_Typ);
6666 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
6669 Lbd := Type_Low_Bound (Indx_Typ);
6670 Hbd := Type_High_Bound (Indx_Typ);
6674 if Compile_Time_Known_Value (Lbd)
6675 and then Compile_Time_Known_Value (Hbd)
6677 if Expr_Value (Hbd) < Expr_Value (Lbd) then
6687 -- If no null indexes, then type is not fully initialized
6693 elsif Is_Record_Type (Typ) then
6694 if Has_Discriminants (Typ)
6696 Present (Discriminant_Default_Value (First_Discriminant (Typ)))
6697 and then Is_Fully_Initialized_Variant (Typ)
6702 -- Controlled records are considered to be fully initialized if
6703 -- there is a user defined Initialize routine. This may not be
6704 -- entirely correct, but as the spec notes, we are guessing here
6705 -- what is best from the point of view of issuing warnings.
6707 if Is_Controlled (Typ) then
6709 Utyp : constant Entity_Id := Underlying_Type (Typ);
6712 if Present (Utyp) then
6714 Init : constant Entity_Id :=
6716 (Underlying_Type (Typ), Name_Initialize));
6720 and then Comes_From_Source (Init)
6722 Is_Predefined_File_Name
6723 (File_Name (Get_Source_File_Index (Sloc (Init))))
6727 elsif Has_Null_Extension (Typ)
6729 Is_Fully_Initialized_Type
6730 (Etype (Base_Type (Typ)))
6739 -- Otherwise see if all record components are initialized
6745 Ent := First_Entity (Typ);
6746 while Present (Ent) loop
6747 if Chars (Ent) = Name_uController then
6750 elsif Ekind (Ent) = E_Component
6751 and then (No (Parent (Ent))
6752 or else No (Expression (Parent (Ent))))
6753 and then not Is_Fully_Initialized_Type (Etype (Ent))
6755 -- Special VM case for tag components, which need to be
6756 -- defined in this case, but are never initialized as VMs
6757 -- are using other dispatching mechanisms. Ignore this
6758 -- uninitialized case. Note that this applies both to the
6759 -- uTag entry and the main vtable pointer (CPP_Class case).
6761 and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
6770 -- No uninitialized components, so type is fully initialized.
6771 -- Note that this catches the case of no components as well.
6775 elsif Is_Concurrent_Type (Typ) then
6778 elsif Is_Private_Type (Typ) then
6780 U : constant Entity_Id := Underlying_Type (Typ);
6786 return Is_Fully_Initialized_Type (U);
6793 end Is_Fully_Initialized_Type;
6795 ----------------------------------
6796 -- Is_Fully_Initialized_Variant --
6797 ----------------------------------
6799 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
6800 Loc : constant Source_Ptr := Sloc (Typ);
6801 Constraints : constant List_Id := New_List;
6802 Components : constant Elist_Id := New_Elmt_List;
6803 Comp_Elmt : Elmt_Id;
6805 Comp_List : Node_Id;
6807 Discr_Val : Node_Id;
6809 Report_Errors : Boolean;
6810 pragma Warnings (Off, Report_Errors);
6813 if Serious_Errors_Detected > 0 then
6817 if Is_Record_Type (Typ)
6818 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
6819 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
6821 Comp_List := Component_List (Type_Definition (Parent (Typ)));
6823 Discr := First_Discriminant (Typ);
6824 while Present (Discr) loop
6825 if Nkind (Parent (Discr)) = N_Discriminant_Specification then
6826 Discr_Val := Expression (Parent (Discr));
6828 if Present (Discr_Val)
6829 and then Is_OK_Static_Expression (Discr_Val)
6831 Append_To (Constraints,
6832 Make_Component_Association (Loc,
6833 Choices => New_List (New_Occurrence_Of (Discr, Loc)),
6834 Expression => New_Copy (Discr_Val)));
6842 Next_Discriminant (Discr);
6847 Comp_List => Comp_List,
6848 Governed_By => Constraints,
6850 Report_Errors => Report_Errors);
6852 -- Check that each component present is fully initialized
6854 Comp_Elmt := First_Elmt (Components);
6855 while Present (Comp_Elmt) loop
6856 Comp_Id := Node (Comp_Elmt);
6858 if Ekind (Comp_Id) = E_Component
6859 and then (No (Parent (Comp_Id))
6860 or else No (Expression (Parent (Comp_Id))))
6861 and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
6866 Next_Elmt (Comp_Elmt);
6871 elsif Is_Private_Type (Typ) then
6873 U : constant Entity_Id := Underlying_Type (Typ);
6879 return Is_Fully_Initialized_Variant (U);
6885 end Is_Fully_Initialized_Variant;
6891 -- We seem to have a lot of overlapping functions that do similar things
6892 -- (testing for left hand sides or lvalues???). Anyway, since this one is
6893 -- purely syntactic, it should be in Sem_Aux I would think???
6895 function Is_LHS (N : Node_Id) return Boolean is
6896 P : constant Node_Id := Parent (N);
6899 if Nkind (P) = N_Assignment_Statement then
6900 return Name (P) = N;
6903 Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
6905 return N = Prefix (P) and then Is_LHS (P);
6912 ----------------------------
6913 -- Is_Inherited_Operation --
6914 ----------------------------
6916 function Is_Inherited_Operation (E : Entity_Id) return Boolean is
6917 Kind : constant Node_Kind := Nkind (Parent (E));
6919 pragma Assert (Is_Overloadable (E));
6920 return Kind = N_Full_Type_Declaration
6921 or else Kind = N_Private_Extension_Declaration
6922 or else Kind = N_Subtype_Declaration
6923 or else (Ekind (E) = E_Enumeration_Literal
6924 and then Is_Derived_Type (Etype (E)));
6925 end Is_Inherited_Operation;
6927 -------------------------------------
6928 -- Is_Inherited_Operation_For_Type --
6929 -------------------------------------
6931 function Is_Inherited_Operation_For_Type
6932 (E : Entity_Id; Typ : Entity_Id) return Boolean
6935 return Is_Inherited_Operation (E)
6936 and then Etype (Parent (E)) = Typ;
6937 end Is_Inherited_Operation_For_Type;
6939 -----------------------------
6940 -- Is_Library_Level_Entity --
6941 -----------------------------
6943 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
6945 -- The following is a small optimization, and it also properly handles
6946 -- discriminals, which in task bodies might appear in expressions before
6947 -- the corresponding procedure has been created, and which therefore do
6948 -- not have an assigned scope.
6950 if Is_Formal (E) then
6954 -- Normal test is simply that the enclosing dynamic scope is Standard
6956 return Enclosing_Dynamic_Scope (E) = Standard_Standard;
6957 end Is_Library_Level_Entity;
6959 ---------------------------------
6960 -- Is_Local_Variable_Reference --
6961 ---------------------------------
6963 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
6965 if not Is_Entity_Name (Expr) then
6970 Ent : constant Entity_Id := Entity (Expr);
6971 Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
6973 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
6976 return Present (Sub) and then Sub = Current_Subprogram;
6980 end Is_Local_Variable_Reference;
6982 -------------------------
6983 -- Is_Object_Reference --
6984 -------------------------
6986 function Is_Object_Reference (N : Node_Id) return Boolean is
6988 if Is_Entity_Name (N) then
6989 return Present (Entity (N)) and then Is_Object (Entity (N));
6993 when N_Indexed_Component | N_Slice =>
6995 Is_Object_Reference (Prefix (N))
6996 or else Is_Access_Type (Etype (Prefix (N)));
6998 -- In Ada95, a function call is a constant object; a procedure
7001 when N_Function_Call =>
7002 return Etype (N) /= Standard_Void_Type;
7004 -- A reference to the stream attribute Input is a function call
7006 when N_Attribute_Reference =>
7007 return Attribute_Name (N) = Name_Input;
7009 when N_Selected_Component =>
7011 Is_Object_Reference (Selector_Name (N))
7013 (Is_Object_Reference (Prefix (N))
7014 or else Is_Access_Type (Etype (Prefix (N))));
7016 when N_Explicit_Dereference =>
7019 -- A view conversion of a tagged object is an object reference
7021 when N_Type_Conversion =>
7022 return Is_Tagged_Type (Etype (Subtype_Mark (N)))
7023 and then Is_Tagged_Type (Etype (Expression (N)))
7024 and then Is_Object_Reference (Expression (N));
7026 -- An unchecked type conversion is considered to be an object if
7027 -- the operand is an object (this construction arises only as a
7028 -- result of expansion activities).
7030 when N_Unchecked_Type_Conversion =>
7037 end Is_Object_Reference;
7039 -----------------------------------
7040 -- Is_OK_Variable_For_Out_Formal --
7041 -----------------------------------
7043 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
7045 Note_Possible_Modification (AV, Sure => True);
7047 -- We must reject parenthesized variable names. The check for
7048 -- Comes_From_Source is present because there are currently
7049 -- cases where the compiler violates this rule (e.g. passing
7050 -- a task object to its controlled Initialize routine).
7052 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
7055 -- A variable is always allowed
7057 elsif Is_Variable (AV) then
7060 -- Unchecked conversions are allowed only if they come from the
7061 -- generated code, which sometimes uses unchecked conversions for out
7062 -- parameters in cases where code generation is unaffected. We tell
7063 -- source unchecked conversions by seeing if they are rewrites of an
7064 -- original Unchecked_Conversion function call, or of an explicit
7065 -- conversion of a function call.
7067 elsif Nkind (AV) = N_Unchecked_Type_Conversion then
7068 if Nkind (Original_Node (AV)) = N_Function_Call then
7071 elsif Comes_From_Source (AV)
7072 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
7076 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
7077 return Is_OK_Variable_For_Out_Formal (Expression (AV));
7083 -- Normal type conversions are allowed if argument is a variable
7085 elsif Nkind (AV) = N_Type_Conversion then
7086 if Is_Variable (Expression (AV))
7087 and then Paren_Count (Expression (AV)) = 0
7089 Note_Possible_Modification (Expression (AV), Sure => True);
7092 -- We also allow a non-parenthesized expression that raises
7093 -- constraint error if it rewrites what used to be a variable
7095 elsif Raises_Constraint_Error (Expression (AV))
7096 and then Paren_Count (Expression (AV)) = 0
7097 and then Is_Variable (Original_Node (Expression (AV)))
7101 -- Type conversion of something other than a variable
7107 -- If this node is rewritten, then test the original form, if that is
7108 -- OK, then we consider the rewritten node OK (for example, if the
7109 -- original node is a conversion, then Is_Variable will not be true
7110 -- but we still want to allow the conversion if it converts a variable).
7112 elsif Original_Node (AV) /= AV then
7113 return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
7115 -- All other non-variables are rejected
7120 end Is_OK_Variable_For_Out_Formal;
7122 -----------------------------------
7123 -- Is_Partially_Initialized_Type --
7124 -----------------------------------
7126 function Is_Partially_Initialized_Type
7128 Include_Implicit : Boolean := True) return Boolean
7131 if Is_Scalar_Type (Typ) then
7134 elsif Is_Access_Type (Typ) then
7135 return Include_Implicit;
7137 elsif Is_Array_Type (Typ) then
7139 -- If component type is partially initialized, so is array type
7141 if Is_Partially_Initialized_Type
7142 (Component_Type (Typ), Include_Implicit)
7146 -- Otherwise we are only partially initialized if we are fully
7147 -- initialized (this is the empty array case, no point in us
7148 -- duplicating that code here).
7151 return Is_Fully_Initialized_Type (Typ);
7154 elsif Is_Record_Type (Typ) then
7156 -- A discriminated type is always partially initialized if in
7159 if Has_Discriminants (Typ) and then Include_Implicit then
7162 -- A tagged type is always partially initialized
7164 elsif Is_Tagged_Type (Typ) then
7167 -- Case of non-discriminated record
7173 Component_Present : Boolean := False;
7174 -- Set True if at least one component is present. If no
7175 -- components are present, then record type is fully
7176 -- initialized (another odd case, like the null array).
7179 -- Loop through components
7181 Ent := First_Entity (Typ);
7182 while Present (Ent) loop
7183 if Ekind (Ent) = E_Component then
7184 Component_Present := True;
7186 -- If a component has an initialization expression then
7187 -- the enclosing record type is partially initialized
7189 if Present (Parent (Ent))
7190 and then Present (Expression (Parent (Ent)))
7194 -- If a component is of a type which is itself partially
7195 -- initialized, then the enclosing record type is also.
7197 elsif Is_Partially_Initialized_Type
7198 (Etype (Ent), Include_Implicit)
7207 -- No initialized components found. If we found any components
7208 -- they were all uninitialized so the result is false.
7210 if Component_Present then
7213 -- But if we found no components, then all the components are
7214 -- initialized so we consider the type to be initialized.
7222 -- Concurrent types are always fully initialized
7224 elsif Is_Concurrent_Type (Typ) then
7227 -- For a private type, go to underlying type. If there is no underlying
7228 -- type then just assume this partially initialized. Not clear if this
7229 -- can happen in a non-error case, but no harm in testing for this.
7231 elsif Is_Private_Type (Typ) then
7233 U : constant Entity_Id := Underlying_Type (Typ);
7238 return Is_Partially_Initialized_Type (U, Include_Implicit);
7242 -- For any other type (are there any?) assume partially initialized
7247 end Is_Partially_Initialized_Type;
7249 ------------------------------------
7250 -- Is_Potentially_Persistent_Type --
7251 ------------------------------------
7253 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
7258 -- For private type, test corresponding full type
7260 if Is_Private_Type (T) then
7261 return Is_Potentially_Persistent_Type (Full_View (T));
7263 -- Scalar types are potentially persistent
7265 elsif Is_Scalar_Type (T) then
7268 -- Record type is potentially persistent if not tagged and the types of
7269 -- all it components are potentially persistent, and no component has
7270 -- an initialization expression.
7272 elsif Is_Record_Type (T)
7273 and then not Is_Tagged_Type (T)
7274 and then not Is_Partially_Initialized_Type (T)
7276 Comp := First_Component (T);
7277 while Present (Comp) loop
7278 if not Is_Potentially_Persistent_Type (Etype (Comp)) then
7287 -- Array type is potentially persistent if its component type is
7288 -- potentially persistent and if all its constraints are static.
7290 elsif Is_Array_Type (T) then
7291 if not Is_Potentially_Persistent_Type (Component_Type (T)) then
7295 Indx := First_Index (T);
7296 while Present (Indx) loop
7297 if not Is_OK_Static_Subtype (Etype (Indx)) then
7306 -- All other types are not potentially persistent
7311 end Is_Potentially_Persistent_Type;
7313 ---------------------------------
7314 -- Is_Protected_Self_Reference --
7315 ---------------------------------
7317 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
7319 function In_Access_Definition (N : Node_Id) return Boolean;
7320 -- Returns true if N belongs to an access definition
7322 --------------------------
7323 -- In_Access_Definition --
7324 --------------------------
7326 function In_Access_Definition (N : Node_Id) return Boolean is
7331 while Present (P) loop
7332 if Nkind (P) = N_Access_Definition then
7340 end In_Access_Definition;
7342 -- Start of processing for Is_Protected_Self_Reference
7345 -- Verify that prefix is analyzed and has the proper form. Note that
7346 -- the attributes Elab_Spec, Elab_Body, and UET_Address, which also
7347 -- produce the address of an entity, do not analyze their prefix
7348 -- because they denote entities that are not necessarily visible.
7349 -- Neither of them can apply to a protected type.
7351 return Ada_Version >= Ada_2005
7352 and then Is_Entity_Name (N)
7353 and then Present (Entity (N))
7354 and then Is_Protected_Type (Entity (N))
7355 and then In_Open_Scopes (Entity (N))
7356 and then not In_Access_Definition (N);
7357 end Is_Protected_Self_Reference;
7359 -----------------------------
7360 -- Is_RCI_Pkg_Spec_Or_Body --
7361 -----------------------------
7363 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
7365 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
7366 -- Return True if the unit of Cunit is an RCI package declaration
7368 ---------------------------
7369 -- Is_RCI_Pkg_Decl_Cunit --
7370 ---------------------------
7372 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
7373 The_Unit : constant Node_Id := Unit (Cunit);
7376 if Nkind (The_Unit) /= N_Package_Declaration then
7380 return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
7381 end Is_RCI_Pkg_Decl_Cunit;
7383 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
7386 return Is_RCI_Pkg_Decl_Cunit (Cunit)
7388 (Nkind (Unit (Cunit)) = N_Package_Body
7389 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
7390 end Is_RCI_Pkg_Spec_Or_Body;
7392 -----------------------------------------
7393 -- Is_Remote_Access_To_Class_Wide_Type --
7394 -----------------------------------------
7396 function Is_Remote_Access_To_Class_Wide_Type
7397 (E : Entity_Id) return Boolean
7400 -- A remote access to class-wide type is a general access to object type
7401 -- declared in the visible part of a Remote_Types or Remote_Call_
7404 return Ekind (E) = E_General_Access_Type
7405 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
7406 end Is_Remote_Access_To_Class_Wide_Type;
7408 -----------------------------------------
7409 -- Is_Remote_Access_To_Subprogram_Type --
7410 -----------------------------------------
7412 function Is_Remote_Access_To_Subprogram_Type
7413 (E : Entity_Id) return Boolean
7416 return (Ekind (E) = E_Access_Subprogram_Type
7417 or else (Ekind (E) = E_Record_Type
7418 and then Present (Corresponding_Remote_Type (E))))
7419 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
7420 end Is_Remote_Access_To_Subprogram_Type;
7422 --------------------
7423 -- Is_Remote_Call --
7424 --------------------
7426 function Is_Remote_Call (N : Node_Id) return Boolean is
7428 if Nkind (N) /= N_Procedure_Call_Statement
7429 and then Nkind (N) /= N_Function_Call
7431 -- An entry call cannot be remote
7435 elsif Nkind (Name (N)) in N_Has_Entity
7436 and then Is_Remote_Call_Interface (Entity (Name (N)))
7438 -- A subprogram declared in the spec of a RCI package is remote
7442 elsif Nkind (Name (N)) = N_Explicit_Dereference
7443 and then Is_Remote_Access_To_Subprogram_Type
7444 (Etype (Prefix (Name (N))))
7446 -- The dereference of a RAS is a remote call
7450 elsif Present (Controlling_Argument (N))
7451 and then Is_Remote_Access_To_Class_Wide_Type
7452 (Etype (Controlling_Argument (N)))
7454 -- Any primitive operation call with a controlling argument of
7455 -- a RACW type is a remote call.
7460 -- All other calls are local calls
7465 ----------------------
7466 -- Is_Renamed_Entry --
7467 ----------------------
7469 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
7470 Orig_Node : Node_Id := Empty;
7471 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
7473 function Is_Entry (Nam : Node_Id) return Boolean;
7474 -- Determine whether Nam is an entry. Traverse selectors if there are
7475 -- nested selected components.
7481 function Is_Entry (Nam : Node_Id) return Boolean is
7483 if Nkind (Nam) = N_Selected_Component then
7484 return Is_Entry (Selector_Name (Nam));
7487 return Ekind (Entity (Nam)) = E_Entry;
7490 -- Start of processing for Is_Renamed_Entry
7493 if Present (Alias (Proc_Nam)) then
7494 Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
7497 -- Look for a rewritten subprogram renaming declaration
7499 if Nkind (Subp_Decl) = N_Subprogram_Declaration
7500 and then Present (Original_Node (Subp_Decl))
7502 Orig_Node := Original_Node (Subp_Decl);
7505 -- The rewritten subprogram is actually an entry
7507 if Present (Orig_Node)
7508 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
7509 and then Is_Entry (Name (Orig_Node))
7515 end Is_Renamed_Entry;
7517 ----------------------
7518 -- Is_Selector_Name --
7519 ----------------------
7521 function Is_Selector_Name (N : Node_Id) return Boolean is
7523 if not Is_List_Member (N) then
7525 P : constant Node_Id := Parent (N);
7526 K : constant Node_Kind := Nkind (P);
7529 (K = N_Expanded_Name or else
7530 K = N_Generic_Association or else
7531 K = N_Parameter_Association or else
7532 K = N_Selected_Component)
7533 and then Selector_Name (P) = N;
7538 L : constant List_Id := List_Containing (N);
7539 P : constant Node_Id := Parent (L);
7541 return (Nkind (P) = N_Discriminant_Association
7542 and then Selector_Names (P) = L)
7544 (Nkind (P) = N_Component_Association
7545 and then Choices (P) = L);
7548 end Is_Selector_Name;
7550 ----------------------------------
7551 -- Is_SPARK_Initialization_Expr --
7552 ----------------------------------
7554 function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
7557 Comp_Assn : Node_Id;
7558 Orig_N : constant Node_Id := Original_Node (N);
7563 if not Comes_From_Source (Orig_N) then
7567 pragma Assert (Nkind (Orig_N) in N_Subexpr);
7569 case Nkind (Orig_N) is
7570 when N_Character_Literal |
7578 if Is_Entity_Name (Orig_N)
7579 and then Present (Entity (Orig_N)) -- needed in some cases
7581 case Ekind (Entity (Orig_N)) is
7583 E_Enumeration_Literal |
7588 if Is_Type (Entity (Orig_N)) then
7596 when N_Qualified_Expression |
7597 N_Type_Conversion =>
7598 Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N));
7601 Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
7605 N_Membership_Test =>
7606 Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
7607 and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
7610 N_Extension_Aggregate =>
7611 if Nkind (Orig_N) = N_Extension_Aggregate then
7612 Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N));
7615 Expr := First (Expressions (Orig_N));
7616 while Present (Expr) loop
7617 if not Is_SPARK_Initialization_Expr (Expr) then
7625 Comp_Assn := First (Component_Associations (Orig_N));
7626 while Present (Comp_Assn) loop
7627 Expr := Expression (Comp_Assn);
7628 if Present (Expr) -- needed for box association
7629 and then not Is_SPARK_Initialization_Expr (Expr)
7638 when N_Attribute_Reference =>
7639 if Nkind (Prefix (Orig_N)) in N_Subexpr then
7640 Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N));
7643 Expr := First (Expressions (Orig_N));
7644 while Present (Expr) loop
7645 if not Is_SPARK_Initialization_Expr (Expr) then
7653 -- Selected components might be expanded named not yet resolved, so
7654 -- default on the safe side. (Eg on sparklex.ads)
7656 when N_Selected_Component =>
7665 end Is_SPARK_Initialization_Expr;
7667 -------------------------------
7668 -- Is_SPARK_Object_Reference --
7669 -------------------------------
7671 function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
7673 if Is_Entity_Name (N) then
7674 return Present (Entity (N))
7676 (Ekind_In (Entity (N), E_Constant, E_Variable)
7677 or else Ekind (Entity (N)) in Formal_Kind);
7681 when N_Selected_Component =>
7682 return Is_SPARK_Object_Reference (Prefix (N));
7688 end Is_SPARK_Object_Reference;
7694 function Is_Statement (N : Node_Id) return Boolean is
7697 Nkind (N) in N_Statement_Other_Than_Procedure_Call
7698 or else Nkind (N) = N_Procedure_Call_Statement;
7701 ---------------------------------
7702 -- Is_Synchronized_Tagged_Type --
7703 ---------------------------------
7705 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
7706 Kind : constant Entity_Kind := Ekind (Base_Type (E));
7709 -- A task or protected type derived from an interface is a tagged type.
7710 -- Such a tagged type is called a synchronized tagged type, as are
7711 -- synchronized interfaces and private extensions whose declaration
7712 -- includes the reserved word synchronized.
7714 return (Is_Tagged_Type (E)
7715 and then (Kind = E_Task_Type
7716 or else Kind = E_Protected_Type))
7719 and then Is_Synchronized_Interface (E))
7721 (Ekind (E) = E_Record_Type_With_Private
7722 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
7723 and then (Synchronized_Present (Parent (E))
7724 or else Is_Synchronized_Interface (Etype (E))));
7725 end Is_Synchronized_Tagged_Type;
7731 function Is_Transfer (N : Node_Id) return Boolean is
7732 Kind : constant Node_Kind := Nkind (N);
7735 if Kind = N_Simple_Return_Statement
7737 Kind = N_Extended_Return_Statement
7739 Kind = N_Goto_Statement
7741 Kind = N_Raise_Statement
7743 Kind = N_Requeue_Statement
7747 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
7748 and then No (Condition (N))
7752 elsif Kind = N_Procedure_Call_Statement
7753 and then Is_Entity_Name (Name (N))
7754 and then Present (Entity (Name (N)))
7755 and then No_Return (Entity (Name (N)))
7759 elsif Nkind (Original_Node (N)) = N_Raise_Statement then
7771 function Is_True (U : Uint) return Boolean is
7776 -------------------------------
7777 -- Is_Universal_Numeric_Type --
7778 -------------------------------
7780 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
7782 return T = Universal_Integer or else T = Universal_Real;
7783 end Is_Universal_Numeric_Type;
7789 function Is_Value_Type (T : Entity_Id) return Boolean is
7791 return VM_Target = CLI_Target
7792 and then Nkind (T) in N_Has_Chars
7793 and then Chars (T) /= No_Name
7794 and then Get_Name_String (Chars (T)) = "valuetype";
7797 ---------------------
7798 -- Is_VMS_Operator --
7799 ---------------------
7801 function Is_VMS_Operator (Op : Entity_Id) return Boolean is
7803 -- The VMS operators are declared in a child of System that is loaded
7804 -- through pragma Extend_System. In some rare cases a program is run
7805 -- with this extension but without indicating that the target is VMS.
7807 return Ekind (Op) = E_Function
7808 and then Is_Intrinsic_Subprogram (Op)
7810 ((Present_System_Aux
7811 and then Scope (Op) = System_Aux_Id)
7814 and then Scope (Scope (Op)) = RTU_Entity (System)));
7815 end Is_VMS_Operator;
7821 function Is_Variable
7823 Use_Original_Node : Boolean := True) return Boolean
7825 Orig_Node : Node_Id;
7827 function In_Protected_Function (E : Entity_Id) return Boolean;
7828 -- Within a protected function, the private components of the enclosing
7829 -- protected type are constants. A function nested within a (protected)
7830 -- procedure is not itself protected.
7832 function Is_Variable_Prefix (P : Node_Id) return Boolean;
7833 -- Prefixes can involve implicit dereferences, in which case we must
7834 -- test for the case of a reference of a constant access type, which can
7835 -- can never be a variable.
7837 ---------------------------
7838 -- In_Protected_Function --
7839 ---------------------------
7841 function In_Protected_Function (E : Entity_Id) return Boolean is
7842 Prot : constant Entity_Id := Scope (E);
7846 if not Is_Protected_Type (Prot) then
7850 while Present (S) and then S /= Prot loop
7851 if Ekind (S) = E_Function and then Scope (S) = Prot then
7860 end In_Protected_Function;
7862 ------------------------
7863 -- Is_Variable_Prefix --
7864 ------------------------
7866 function Is_Variable_Prefix (P : Node_Id) return Boolean is
7868 if Is_Access_Type (Etype (P)) then
7869 return not Is_Access_Constant (Root_Type (Etype (P)));
7871 -- For the case of an indexed component whose prefix has a packed
7872 -- array type, the prefix has been rewritten into a type conversion.
7873 -- Determine variable-ness from the converted expression.
7875 elsif Nkind (P) = N_Type_Conversion
7876 and then not Comes_From_Source (P)
7877 and then Is_Array_Type (Etype (P))
7878 and then Is_Packed (Etype (P))
7880 return Is_Variable (Expression (P));
7883 return Is_Variable (P);
7885 end Is_Variable_Prefix;
7887 -- Start of processing for Is_Variable
7890 -- Check if we perform the test on the original node since this may be a
7891 -- test of syntactic categories which must not be disturbed by whatever
7892 -- rewriting might have occurred. For example, an aggregate, which is
7893 -- certainly NOT a variable, could be turned into a variable by
7896 if Use_Original_Node then
7897 Orig_Node := Original_Node (N);
7902 -- Definitely OK if Assignment_OK is set. Since this is something that
7903 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
7905 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
7908 -- Normally we go to the original node, but there is one exception where
7909 -- we use the rewritten node, namely when it is an explicit dereference.
7910 -- The generated code may rewrite a prefix which is an access type with
7911 -- an explicit dereference. The dereference is a variable, even though
7912 -- the original node may not be (since it could be a constant of the
7915 -- In Ada 2005 we have a further case to consider: the prefix may be a
7916 -- function call given in prefix notation. The original node appears to
7917 -- be a selected component, but we need to examine the call.
7919 elsif Nkind (N) = N_Explicit_Dereference
7920 and then Nkind (Orig_Node) /= N_Explicit_Dereference
7921 and then Present (Etype (Orig_Node))
7922 and then Is_Access_Type (Etype (Orig_Node))
7924 -- Note that if the prefix is an explicit dereference that does not
7925 -- come from source, we must check for a rewritten function call in
7926 -- prefixed notation before other forms of rewriting, to prevent a
7930 (Nkind (Orig_Node) = N_Function_Call
7931 and then not Is_Access_Constant (Etype (Prefix (N))))
7933 Is_Variable_Prefix (Original_Node (Prefix (N)));
7935 -- A function call is never a variable
7937 elsif Nkind (N) = N_Function_Call then
7940 -- All remaining checks use the original node
7942 elsif Is_Entity_Name (Orig_Node)
7943 and then Present (Entity (Orig_Node))
7946 E : constant Entity_Id := Entity (Orig_Node);
7947 K : constant Entity_Kind := Ekind (E);
7950 return (K = E_Variable
7951 and then Nkind (Parent (E)) /= N_Exception_Handler)
7952 or else (K = E_Component
7953 and then not In_Protected_Function (E))
7954 or else K = E_Out_Parameter
7955 or else K = E_In_Out_Parameter
7956 or else K = E_Generic_In_Out_Parameter
7958 -- Current instance of type:
7960 or else (Is_Type (E) and then In_Open_Scopes (E))
7961 or else (Is_Incomplete_Or_Private_Type (E)
7962 and then In_Open_Scopes (Full_View (E)));
7966 case Nkind (Orig_Node) is
7967 when N_Indexed_Component | N_Slice =>
7968 return Is_Variable_Prefix (Prefix (Orig_Node));
7970 when N_Selected_Component =>
7971 return Is_Variable_Prefix (Prefix (Orig_Node))
7972 and then Is_Variable (Selector_Name (Orig_Node));
7974 -- For an explicit dereference, the type of the prefix cannot
7975 -- be an access to constant or an access to subprogram.
7977 when N_Explicit_Dereference =>
7979 Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
7981 return Is_Access_Type (Typ)
7982 and then not Is_Access_Constant (Root_Type (Typ))
7983 and then Ekind (Typ) /= E_Access_Subprogram_Type;
7986 -- The type conversion is the case where we do not deal with the
7987 -- context dependent special case of an actual parameter. Thus
7988 -- the type conversion is only considered a variable for the
7989 -- purposes of this routine if the target type is tagged. However,
7990 -- a type conversion is considered to be a variable if it does not
7991 -- come from source (this deals for example with the conversions
7992 -- of expressions to their actual subtypes).
7994 when N_Type_Conversion =>
7995 return Is_Variable (Expression (Orig_Node))
7997 (not Comes_From_Source (Orig_Node)
7999 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
8001 Is_Tagged_Type (Etype (Expression (Orig_Node)))));
8003 -- GNAT allows an unchecked type conversion as a variable. This
8004 -- only affects the generation of internal expanded code, since
8005 -- calls to instantiations of Unchecked_Conversion are never
8006 -- considered variables (since they are function calls).
8007 -- This is also true for expression actions.
8009 when N_Unchecked_Type_Conversion =>
8010 return Is_Variable (Expression (Orig_Node));
8018 ---------------------------
8019 -- Is_Visibly_Controlled --
8020 ---------------------------
8022 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
8023 Root : constant Entity_Id := Root_Type (T);
8025 return Chars (Scope (Root)) = Name_Finalization
8026 and then Chars (Scope (Scope (Root))) = Name_Ada
8027 and then Scope (Scope (Scope (Root))) = Standard_Standard;
8028 end Is_Visibly_Controlled;
8030 ------------------------
8031 -- Is_Volatile_Object --
8032 ------------------------
8034 function Is_Volatile_Object (N : Node_Id) return Boolean is
8036 function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
8037 -- Determines if given object has volatile components
8039 function Is_Volatile_Prefix (N : Node_Id) return Boolean;
8040 -- If prefix is an implicit dereference, examine designated type
8042 ------------------------
8043 -- Is_Volatile_Prefix --
8044 ------------------------
8046 function Is_Volatile_Prefix (N : Node_Id) return Boolean is
8047 Typ : constant Entity_Id := Etype (N);
8050 if Is_Access_Type (Typ) then
8052 Dtyp : constant Entity_Id := Designated_Type (Typ);
8055 return Is_Volatile (Dtyp)
8056 or else Has_Volatile_Components (Dtyp);
8060 return Object_Has_Volatile_Components (N);
8062 end Is_Volatile_Prefix;
8064 ------------------------------------
8065 -- Object_Has_Volatile_Components --
8066 ------------------------------------
8068 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
8069 Typ : constant Entity_Id := Etype (N);
8072 if Is_Volatile (Typ)
8073 or else Has_Volatile_Components (Typ)
8077 elsif Is_Entity_Name (N)
8078 and then (Has_Volatile_Components (Entity (N))
8079 or else Is_Volatile (Entity (N)))
8083 elsif Nkind (N) = N_Indexed_Component
8084 or else Nkind (N) = N_Selected_Component
8086 return Is_Volatile_Prefix (Prefix (N));
8091 end Object_Has_Volatile_Components;
8093 -- Start of processing for Is_Volatile_Object
8096 if Is_Volatile (Etype (N))
8097 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
8101 elsif Nkind (N) = N_Indexed_Component
8102 or else Nkind (N) = N_Selected_Component
8104 return Is_Volatile_Prefix (Prefix (N));
8109 end Is_Volatile_Object;
8111 -------------------------
8112 -- Kill_Current_Values --
8113 -------------------------
8115 procedure Kill_Current_Values
8117 Last_Assignment_Only : Boolean := False)
8120 -- ??? do we have to worry about clearing cached checks?
8122 if Is_Assignable (Ent) then
8123 Set_Last_Assignment (Ent, Empty);
8126 if Is_Object (Ent) then
8127 if not Last_Assignment_Only then
8129 Set_Current_Value (Ent, Empty);
8131 if not Can_Never_Be_Null (Ent) then
8132 Set_Is_Known_Non_Null (Ent, False);
8135 Set_Is_Known_Null (Ent, False);
8137 -- Reset Is_Known_Valid unless type is always valid, or if we have
8138 -- a loop parameter (loop parameters are always valid, since their
8139 -- bounds are defined by the bounds given in the loop header).
8141 if not Is_Known_Valid (Etype (Ent))
8142 and then Ekind (Ent) /= E_Loop_Parameter
8144 Set_Is_Known_Valid (Ent, False);
8148 end Kill_Current_Values;
8150 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
8153 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
8154 -- Clear current value for entity E and all entities chained to E
8156 ------------------------------------------
8157 -- Kill_Current_Values_For_Entity_Chain --
8158 ------------------------------------------
8160 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
8164 while Present (Ent) loop
8165 Kill_Current_Values (Ent, Last_Assignment_Only);
8168 end Kill_Current_Values_For_Entity_Chain;
8170 -- Start of processing for Kill_Current_Values
8173 -- Kill all saved checks, a special case of killing saved values
8175 if not Last_Assignment_Only then
8179 -- Loop through relevant scopes, which includes the current scope and
8180 -- any parent scopes if the current scope is a block or a package.
8185 -- Clear current values of all entities in current scope
8187 Kill_Current_Values_For_Entity_Chain (First_Entity (S));
8189 -- If scope is a package, also clear current values of all
8190 -- private entities in the scope.
8192 if Is_Package_Or_Generic_Package (S)
8193 or else Is_Concurrent_Type (S)
8195 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
8198 -- If this is a not a subprogram, deal with parents
8200 if not Is_Subprogram (S) then
8202 exit Scope_Loop when S = Standard_Standard;
8206 end loop Scope_Loop;
8207 end Kill_Current_Values;
8209 --------------------------
8210 -- Kill_Size_Check_Code --
8211 --------------------------
8213 procedure Kill_Size_Check_Code (E : Entity_Id) is
8215 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
8216 and then Present (Size_Check_Code (E))
8218 Remove (Size_Check_Code (E));
8219 Set_Size_Check_Code (E, Empty);
8221 end Kill_Size_Check_Code;
8223 --------------------------
8224 -- Known_To_Be_Assigned --
8225 --------------------------
8227 function Known_To_Be_Assigned (N : Node_Id) return Boolean is
8228 P : constant Node_Id := Parent (N);
8233 -- Test left side of assignment
8235 when N_Assignment_Statement =>
8236 return N = Name (P);
8238 -- Function call arguments are never lvalues
8240 when N_Function_Call =>
8243 -- Positional parameter for procedure or accept call
8245 when N_Procedure_Call_Statement |
8254 Proc := Get_Subprogram_Entity (P);
8260 -- If we are not a list member, something is strange, so
8261 -- be conservative and return False.
8263 if not Is_List_Member (N) then
8267 -- We are going to find the right formal by stepping forward
8268 -- through the formals, as we step backwards in the actuals.
8270 Form := First_Formal (Proc);
8273 -- If no formal, something is weird, so be conservative
8274 -- and return False.
8285 return Ekind (Form) /= E_In_Parameter;
8288 -- Named parameter for procedure or accept call
8290 when N_Parameter_Association =>
8296 Proc := Get_Subprogram_Entity (Parent (P));
8302 -- Loop through formals to find the one that matches
8304 Form := First_Formal (Proc);
8306 -- If no matching formal, that's peculiar, some kind of
8307 -- previous error, so return False to be conservative.
8313 -- Else test for match
8315 if Chars (Form) = Chars (Selector_Name (P)) then
8316 return Ekind (Form) /= E_In_Parameter;
8323 -- Test for appearing in a conversion that itself appears
8324 -- in an lvalue context, since this should be an lvalue.
8326 when N_Type_Conversion =>
8327 return Known_To_Be_Assigned (P);
8329 -- All other references are definitely not known to be modifications
8335 end Known_To_Be_Assigned;
8337 ---------------------------
8338 -- Last_Source_Statement --
8339 ---------------------------
8341 function Last_Source_Statement (HSS : Node_Id) return Node_Id is
8345 N := Last (Statements (HSS));
8346 while Present (N) loop
8347 exit when Comes_From_Source (N);
8352 end Last_Source_Statement;
8354 ----------------------------------
8355 -- Matching_Static_Array_Bounds --
8356 ----------------------------------
8358 function Matching_Static_Array_Bounds
8360 R_Typ : Node_Id) return Boolean
8362 L_Ndims : constant Nat := Number_Dimensions (L_Typ);
8363 R_Ndims : constant Nat := Number_Dimensions (R_Typ);
8375 if L_Ndims /= R_Ndims then
8379 -- Unconstrained types do not have static bounds
8381 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
8385 -- First treat specially the first dimension, as the lower bound and
8386 -- length of string literals are not stored like those of arrays.
8388 if Ekind (L_Typ) = E_String_Literal_Subtype then
8389 L_Low := String_Literal_Low_Bound (L_Typ);
8390 L_Len := String_Literal_Length (L_Typ);
8392 L_Index := First_Index (L_Typ);
8393 Get_Index_Bounds (L_Index, L_Low, L_High);
8395 if Is_OK_Static_Expression (L_Low)
8396 and then Is_OK_Static_Expression (L_High)
8398 if Expr_Value (L_High) < Expr_Value (L_Low) then
8401 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
8408 if Ekind (R_Typ) = E_String_Literal_Subtype then
8409 R_Low := String_Literal_Low_Bound (R_Typ);
8410 R_Len := String_Literal_Length (R_Typ);
8412 R_Index := First_Index (R_Typ);
8413 Get_Index_Bounds (R_Index, R_Low, R_High);
8415 if Is_OK_Static_Expression (R_Low)
8416 and then Is_OK_Static_Expression (R_High)
8418 if Expr_Value (R_High) < Expr_Value (R_Low) then
8421 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
8428 if Is_OK_Static_Expression (L_Low)
8429 and then Is_OK_Static_Expression (R_Low)
8430 and then Expr_Value (L_Low) = Expr_Value (R_Low)
8431 and then L_Len = R_Len
8438 -- Then treat all other dimensions
8440 for Indx in 2 .. L_Ndims loop
8444 Get_Index_Bounds (L_Index, L_Low, L_High);
8445 Get_Index_Bounds (R_Index, R_Low, R_High);
8447 if Is_OK_Static_Expression (L_Low)
8448 and then Is_OK_Static_Expression (L_High)
8449 and then Is_OK_Static_Expression (R_Low)
8450 and then Is_OK_Static_Expression (R_High)
8451 and then Expr_Value (L_Low) = Expr_Value (R_Low)
8452 and then Expr_Value (L_High) = Expr_Value (R_High)
8460 -- If we fall through the loop, all indexes matched
8463 end Matching_Static_Array_Bounds;
8469 function May_Be_Lvalue (N : Node_Id) return Boolean is
8470 P : constant Node_Id := Parent (N);
8475 -- Test left side of assignment
8477 when N_Assignment_Statement =>
8478 return N = Name (P);
8480 -- Test prefix of component or attribute. Note that the prefix of an
8481 -- explicit or implicit dereference cannot be an l-value.
8483 when N_Attribute_Reference =>
8484 return N = Prefix (P)
8485 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
8487 -- For an expanded name, the name is an lvalue if the expanded name
8488 -- is an lvalue, but the prefix is never an lvalue, since it is just
8489 -- the scope where the name is found.
8491 when N_Expanded_Name =>
8492 if N = Prefix (P) then
8493 return May_Be_Lvalue (P);
8498 -- For a selected component A.B, A is certainly an lvalue if A.B is.
8499 -- B is a little interesting, if we have A.B := 3, there is some
8500 -- discussion as to whether B is an lvalue or not, we choose to say
8501 -- it is. Note however that A is not an lvalue if it is of an access
8502 -- type since this is an implicit dereference.
8504 when N_Selected_Component =>
8506 and then Present (Etype (N))
8507 and then Is_Access_Type (Etype (N))
8511 return May_Be_Lvalue (P);
8514 -- For an indexed component or slice, the index or slice bounds is
8515 -- never an lvalue. The prefix is an lvalue if the indexed component
8516 -- or slice is an lvalue, except if it is an access type, where we
8517 -- have an implicit dereference.
8519 when N_Indexed_Component =>
8521 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
8525 return May_Be_Lvalue (P);
8528 -- Prefix of a reference is an lvalue if the reference is an lvalue
8531 return May_Be_Lvalue (P);
8533 -- Prefix of explicit dereference is never an lvalue
8535 when N_Explicit_Dereference =>
8538 -- Positional parameter for subprogram, entry, or accept call.
8539 -- In older versions of Ada function call arguments are never
8540 -- lvalues. In Ada 2012 functions can have in-out parameters.
8542 when N_Function_Call |
8543 N_Procedure_Call_Statement |
8544 N_Entry_Call_Statement |
8547 if Nkind (P) = N_Function_Call
8548 and then Ada_Version < Ada_2012
8553 -- The following mechanism is clumsy and fragile. A single
8554 -- flag set in Resolve_Actuals would be preferable ???
8562 Proc := Get_Subprogram_Entity (P);
8568 -- If we are not a list member, something is strange, so
8569 -- be conservative and return True.
8571 if not Is_List_Member (N) then
8575 -- We are going to find the right formal by stepping forward
8576 -- through the formals, as we step backwards in the actuals.
8578 Form := First_Formal (Proc);
8581 -- If no formal, something is weird, so be conservative
8593 return Ekind (Form) /= E_In_Parameter;
8596 -- Named parameter for procedure or accept call
8598 when N_Parameter_Association =>
8604 Proc := Get_Subprogram_Entity (Parent (P));
8610 -- Loop through formals to find the one that matches
8612 Form := First_Formal (Proc);
8614 -- If no matching formal, that's peculiar, some kind of
8615 -- previous error, so return True to be conservative.
8621 -- Else test for match
8623 if Chars (Form) = Chars (Selector_Name (P)) then
8624 return Ekind (Form) /= E_In_Parameter;
8631 -- Test for appearing in a conversion that itself appears in an
8632 -- lvalue context, since this should be an lvalue.
8634 when N_Type_Conversion =>
8635 return May_Be_Lvalue (P);
8637 -- Test for appearance in object renaming declaration
8639 when N_Object_Renaming_Declaration =>
8642 -- All other references are definitely not lvalues
8650 -----------------------
8651 -- Mark_Coextensions --
8652 -----------------------
8654 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
8655 Is_Dynamic : Boolean;
8656 -- Indicates whether the context causes nested coextensions to be
8657 -- dynamic or static
8659 function Mark_Allocator (N : Node_Id) return Traverse_Result;
8660 -- Recognize an allocator node and label it as a dynamic coextension
8662 --------------------
8663 -- Mark_Allocator --
8664 --------------------
8666 function Mark_Allocator (N : Node_Id) return Traverse_Result is
8668 if Nkind (N) = N_Allocator then
8670 Set_Is_Dynamic_Coextension (N);
8672 -- If the allocator expression is potentially dynamic, it may
8673 -- be expanded out of order and require dynamic allocation
8674 -- anyway, so we treat the coextension itself as dynamic.
8675 -- Potential optimization ???
8677 elsif Nkind (Expression (N)) = N_Qualified_Expression
8678 and then Nkind (Expression (Expression (N))) = N_Op_Concat
8680 Set_Is_Dynamic_Coextension (N);
8683 Set_Is_Static_Coextension (N);
8690 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
8692 -- Start of processing Mark_Coextensions
8695 case Nkind (Context_Nod) is
8696 when N_Assignment_Statement |
8697 N_Simple_Return_Statement =>
8698 Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
8700 when N_Object_Declaration =>
8701 Is_Dynamic := Nkind (Root_Nod) = N_Allocator;
8703 -- This routine should not be called for constructs which may not
8704 -- contain coextensions.
8707 raise Program_Error;
8710 Mark_Allocators (Root_Nod);
8711 end Mark_Coextensions;
8713 ----------------------
8714 -- Needs_One_Actual --
8715 ----------------------
8717 function Needs_One_Actual (E : Entity_Id) return Boolean is
8721 if Ada_Version >= Ada_2005
8722 and then Present (First_Formal (E))
8724 Formal := Next_Formal (First_Formal (E));
8725 while Present (Formal) loop
8726 if No (Default_Value (Formal)) then
8730 Next_Formal (Formal);
8738 end Needs_One_Actual;
8740 ------------------------
8741 -- New_Copy_List_Tree --
8742 ------------------------
8744 function New_Copy_List_Tree (List : List_Id) return List_Id is
8749 if List = No_List then
8756 while Present (E) loop
8757 Append (New_Copy_Tree (E), NL);
8763 end New_Copy_List_Tree;
8769 use Atree.Unchecked_Access;
8770 use Atree_Private_Part;
8772 -- Our approach here requires a two pass traversal of the tree. The
8773 -- first pass visits all nodes that eventually will be copied looking
8774 -- for defining Itypes. If any defining Itypes are found, then they are
8775 -- copied, and an entry is added to the replacement map. In the second
8776 -- phase, the tree is copied, using the replacement map to replace any
8777 -- Itype references within the copied tree.
8779 -- The following hash tables are used if the Map supplied has more
8780 -- than hash threshold entries to speed up access to the map. If
8781 -- there are fewer entries, then the map is searched sequentially
8782 -- (because setting up a hash table for only a few entries takes
8783 -- more time than it saves.
8785 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
8786 -- Hash function used for hash operations
8792 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
8794 return Nat (E) mod (NCT_Header_Num'Last + 1);
8801 -- The hash table NCT_Assoc associates old entities in the table
8802 -- with their corresponding new entities (i.e. the pairs of entries
8803 -- presented in the original Map argument are Key-Element pairs).
8805 package NCT_Assoc is new Simple_HTable (
8806 Header_Num => NCT_Header_Num,
8807 Element => Entity_Id,
8808 No_Element => Empty,
8810 Hash => New_Copy_Hash,
8811 Equal => Types."=");
8813 ---------------------
8814 -- NCT_Itype_Assoc --
8815 ---------------------
8817 -- The hash table NCT_Itype_Assoc contains entries only for those
8818 -- old nodes which have a non-empty Associated_Node_For_Itype set.
8819 -- The key is the associated node, and the element is the new node
8820 -- itself (NOT the associated node for the new node).
8822 package NCT_Itype_Assoc is new Simple_HTable (
8823 Header_Num => NCT_Header_Num,
8824 Element => Entity_Id,
8825 No_Element => Empty,
8827 Hash => New_Copy_Hash,
8828 Equal => Types."=");
8830 -- Start of processing for New_Copy_Tree function
8832 function New_Copy_Tree
8834 Map : Elist_Id := No_Elist;
8835 New_Sloc : Source_Ptr := No_Location;
8836 New_Scope : Entity_Id := Empty) return Node_Id
8838 Actual_Map : Elist_Id := Map;
8839 -- This is the actual map for the copy. It is initialized with the
8840 -- given elements, and then enlarged as required for Itypes that are
8841 -- copied during the first phase of the copy operation. The visit
8842 -- procedures add elements to this map as Itypes are encountered.
8843 -- The reason we cannot use Map directly, is that it may well be
8844 -- (and normally is) initialized to No_Elist, and if we have mapped
8845 -- entities, we have to reset it to point to a real Elist.
8847 function Assoc (N : Node_Or_Entity_Id) return Node_Id;
8848 -- Called during second phase to map entities into their corresponding
8849 -- copies using Actual_Map. If the argument is not an entity, or is not
8850 -- in Actual_Map, then it is returned unchanged.
8852 procedure Build_NCT_Hash_Tables;
8853 -- Builds hash tables (number of elements >= threshold value)
8855 function Copy_Elist_With_Replacement
8856 (Old_Elist : Elist_Id) return Elist_Id;
8857 -- Called during second phase to copy element list doing replacements
8859 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
8860 -- Called during the second phase to process a copied Itype. The actual
8861 -- copy happened during the first phase (so that we could make the entry
8862 -- in the mapping), but we still have to deal with the descendents of
8863 -- the copied Itype and copy them where necessary.
8865 function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
8866 -- Called during second phase to copy list doing replacements
8868 function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
8869 -- Called during second phase to copy node doing replacements
8871 procedure Visit_Elist (E : Elist_Id);
8872 -- Called during first phase to visit all elements of an Elist
8874 procedure Visit_Field (F : Union_Id; N : Node_Id);
8875 -- Visit a single field, recursing to call Visit_Node or Visit_List
8876 -- if the field is a syntactic descendent of the current node (i.e.
8877 -- its parent is Node N).
8879 procedure Visit_Itype (Old_Itype : Entity_Id);
8880 -- Called during first phase to visit subsidiary fields of a defining
8881 -- Itype, and also create a copy and make an entry in the replacement
8882 -- map for the new copy.
8884 procedure Visit_List (L : List_Id);
8885 -- Called during first phase to visit all elements of a List
8887 procedure Visit_Node (N : Node_Or_Entity_Id);
8888 -- Called during first phase to visit a node and all its subtrees
8894 function Assoc (N : Node_Or_Entity_Id) return Node_Id is
8899 if not Has_Extension (N) or else No (Actual_Map) then
8902 elsif NCT_Hash_Tables_Used then
8903 Ent := NCT_Assoc.Get (Entity_Id (N));
8905 if Present (Ent) then
8911 -- No hash table used, do serial search
8914 E := First_Elmt (Actual_Map);
8915 while Present (E) loop
8916 if Node (E) = N then
8917 return Node (Next_Elmt (E));
8919 E := Next_Elmt (Next_Elmt (E));
8927 ---------------------------
8928 -- Build_NCT_Hash_Tables --
8929 ---------------------------
8931 procedure Build_NCT_Hash_Tables is
8935 if NCT_Hash_Table_Setup then
8937 NCT_Itype_Assoc.Reset;
8940 Elmt := First_Elmt (Actual_Map);
8941 while Present (Elmt) loop
8944 -- Get new entity, and associate old and new
8947 NCT_Assoc.Set (Ent, Node (Elmt));
8949 if Is_Type (Ent) then
8951 Anode : constant Entity_Id :=
8952 Associated_Node_For_Itype (Ent);
8955 if Present (Anode) then
8957 -- Enter a link between the associated node of the
8958 -- old Itype and the new Itype, for updating later
8959 -- when node is copied.
8961 NCT_Itype_Assoc.Set (Anode, Node (Elmt));
8969 NCT_Hash_Tables_Used := True;
8970 NCT_Hash_Table_Setup := True;
8971 end Build_NCT_Hash_Tables;
8973 ---------------------------------
8974 -- Copy_Elist_With_Replacement --
8975 ---------------------------------
8977 function Copy_Elist_With_Replacement
8978 (Old_Elist : Elist_Id) return Elist_Id
8981 New_Elist : Elist_Id;
8984 if No (Old_Elist) then
8988 New_Elist := New_Elmt_List;
8990 M := First_Elmt (Old_Elist);
8991 while Present (M) loop
8992 Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
8998 end Copy_Elist_With_Replacement;
9000 ---------------------------------
9001 -- Copy_Itype_With_Replacement --
9002 ---------------------------------
9004 -- This routine exactly parallels its phase one analog Visit_Itype,
9006 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
9008 -- Translate Next_Entity, Scope and Etype fields, in case they
9009 -- reference entities that have been mapped into copies.
9011 Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
9012 Set_Etype (New_Itype, Assoc (Etype (New_Itype)));
9014 if Present (New_Scope) then
9015 Set_Scope (New_Itype, New_Scope);
9017 Set_Scope (New_Itype, Assoc (Scope (New_Itype)));
9020 -- Copy referenced fields
9022 if Is_Discrete_Type (New_Itype) then
9023 Set_Scalar_Range (New_Itype,
9024 Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
9026 elsif Has_Discriminants (Base_Type (New_Itype)) then
9027 Set_Discriminant_Constraint (New_Itype,
9028 Copy_Elist_With_Replacement
9029 (Discriminant_Constraint (New_Itype)));
9031 elsif Is_Array_Type (New_Itype) then
9032 if Present (First_Index (New_Itype)) then
9033 Set_First_Index (New_Itype,
9034 First (Copy_List_With_Replacement
9035 (List_Containing (First_Index (New_Itype)))));
9038 if Is_Packed (New_Itype) then
9039 Set_Packed_Array_Type (New_Itype,
9040 Copy_Node_With_Replacement
9041 (Packed_Array_Type (New_Itype)));
9044 end Copy_Itype_With_Replacement;
9046 --------------------------------
9047 -- Copy_List_With_Replacement --
9048 --------------------------------
9050 function Copy_List_With_Replacement
9051 (Old_List : List_Id) return List_Id
9057 if Old_List = No_List then
9061 New_List := Empty_List;
9063 E := First (Old_List);
9064 while Present (E) loop
9065 Append (Copy_Node_With_Replacement (E), New_List);
9071 end Copy_List_With_Replacement;
9073 --------------------------------
9074 -- Copy_Node_With_Replacement --
9075 --------------------------------
9077 function Copy_Node_With_Replacement
9078 (Old_Node : Node_Id) return Node_Id
9082 procedure Adjust_Named_Associations
9083 (Old_Node : Node_Id;
9084 New_Node : Node_Id);
9085 -- If a call node has named associations, these are chained through
9086 -- the First_Named_Actual, Next_Named_Actual links. These must be
9087 -- propagated separately to the new parameter list, because these
9088 -- are not syntactic fields.
9090 function Copy_Field_With_Replacement
9091 (Field : Union_Id) return Union_Id;
9092 -- Given Field, which is a field of Old_Node, return a copy of it
9093 -- if it is a syntactic field (i.e. its parent is Node), setting
9094 -- the parent of the copy to poit to New_Node. Otherwise returns
9095 -- the field (possibly mapped if it is an entity).
9097 -------------------------------
9098 -- Adjust_Named_Associations --
9099 -------------------------------
9101 procedure Adjust_Named_Associations
9102 (Old_Node : Node_Id;
9112 Old_E := First (Parameter_Associations (Old_Node));
9113 New_E := First (Parameter_Associations (New_Node));
9114 while Present (Old_E) loop
9115 if Nkind (Old_E) = N_Parameter_Association
9116 and then Present (Next_Named_Actual (Old_E))
9118 if First_Named_Actual (Old_Node)
9119 = Explicit_Actual_Parameter (Old_E)
9121 Set_First_Named_Actual
9122 (New_Node, Explicit_Actual_Parameter (New_E));
9125 -- Now scan parameter list from the beginning,to locate
9126 -- next named actual, which can be out of order.
9128 Old_Next := First (Parameter_Associations (Old_Node));
9129 New_Next := First (Parameter_Associations (New_Node));
9131 while Nkind (Old_Next) /= N_Parameter_Association
9132 or else Explicit_Actual_Parameter (Old_Next)
9133 /= Next_Named_Actual (Old_E)
9139 Set_Next_Named_Actual
9140 (New_E, Explicit_Actual_Parameter (New_Next));
9146 end Adjust_Named_Associations;
9148 ---------------------------------
9149 -- Copy_Field_With_Replacement --
9150 ---------------------------------
9152 function Copy_Field_With_Replacement
9153 (Field : Union_Id) return Union_Id
9156 if Field = Union_Id (Empty) then
9159 elsif Field in Node_Range then
9161 Old_N : constant Node_Id := Node_Id (Field);
9165 -- If syntactic field, as indicated by the parent pointer
9166 -- being set, then copy the referenced node recursively.
9168 if Parent (Old_N) = Old_Node then
9169 New_N := Copy_Node_With_Replacement (Old_N);
9171 if New_N /= Old_N then
9172 Set_Parent (New_N, New_Node);
9175 -- For semantic fields, update possible entity reference
9176 -- from the replacement map.
9179 New_N := Assoc (Old_N);
9182 return Union_Id (New_N);
9185 elsif Field in List_Range then
9187 Old_L : constant List_Id := List_Id (Field);
9191 -- If syntactic field, as indicated by the parent pointer,
9192 -- then recursively copy the entire referenced list.
9194 if Parent (Old_L) = Old_Node then
9195 New_L := Copy_List_With_Replacement (Old_L);
9196 Set_Parent (New_L, New_Node);
9198 -- For semantic list, just returned unchanged
9204 return Union_Id (New_L);
9207 -- Anything other than a list or a node is returned unchanged
9212 end Copy_Field_With_Replacement;
9214 -- Start of processing for Copy_Node_With_Replacement
9217 if Old_Node <= Empty_Or_Error then
9220 elsif Has_Extension (Old_Node) then
9221 return Assoc (Old_Node);
9224 New_Node := New_Copy (Old_Node);
9226 -- If the node we are copying is the associated node of a
9227 -- previously copied Itype, then adjust the associated node
9228 -- of the copy of that Itype accordingly.
9230 if Present (Actual_Map) then
9236 -- Case of hash table used
9238 if NCT_Hash_Tables_Used then
9239 Ent := NCT_Itype_Assoc.Get (Old_Node);
9241 if Present (Ent) then
9242 Set_Associated_Node_For_Itype (Ent, New_Node);
9245 -- Case of no hash table used
9248 E := First_Elmt (Actual_Map);
9249 while Present (E) loop
9250 if Is_Itype (Node (E))
9252 Old_Node = Associated_Node_For_Itype (Node (E))
9254 Set_Associated_Node_For_Itype
9255 (Node (Next_Elmt (E)), New_Node);
9258 E := Next_Elmt (Next_Elmt (E));
9264 -- Recursively copy descendents
9267 (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
9269 (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
9271 (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
9273 (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
9275 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
9277 -- Adjust Sloc of new node if necessary
9279 if New_Sloc /= No_Location then
9280 Set_Sloc (New_Node, New_Sloc);
9282 -- If we adjust the Sloc, then we are essentially making
9283 -- a completely new node, so the Comes_From_Source flag
9284 -- should be reset to the proper default value.
9286 Nodes.Table (New_Node).Comes_From_Source :=
9287 Default_Node.Comes_From_Source;
9290 -- If the node is call and has named associations,
9291 -- set the corresponding links in the copy.
9293 if (Nkind (Old_Node) = N_Function_Call
9294 or else Nkind (Old_Node) = N_Entry_Call_Statement
9296 Nkind (Old_Node) = N_Procedure_Call_Statement)
9297 and then Present (First_Named_Actual (Old_Node))
9299 Adjust_Named_Associations (Old_Node, New_Node);
9302 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
9303 -- The replacement mechanism applies to entities, and is not used
9304 -- here. Eventually we may need a more general graph-copying
9305 -- routine. For now, do a sequential search to find desired node.
9307 if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
9308 and then Present (First_Real_Statement (Old_Node))
9311 Old_F : constant Node_Id := First_Real_Statement (Old_Node);
9315 N1 := First (Statements (Old_Node));
9316 N2 := First (Statements (New_Node));
9318 while N1 /= Old_F loop
9323 Set_First_Real_Statement (New_Node, N2);
9328 -- All done, return copied node
9331 end Copy_Node_With_Replacement;
9337 procedure Visit_Elist (E : Elist_Id) is
9341 Elmt := First_Elmt (E);
9343 while Elmt /= No_Elmt loop
9344 Visit_Node (Node (Elmt));
9354 procedure Visit_Field (F : Union_Id; N : Node_Id) is
9356 if F = Union_Id (Empty) then
9359 elsif F in Node_Range then
9361 -- Copy node if it is syntactic, i.e. its parent pointer is
9362 -- set to point to the field that referenced it (certain
9363 -- Itypes will also meet this criterion, which is fine, since
9364 -- these are clearly Itypes that do need to be copied, since
9365 -- we are copying their parent.)
9367 if Parent (Node_Id (F)) = N then
9368 Visit_Node (Node_Id (F));
9371 -- Another case, if we are pointing to an Itype, then we want
9372 -- to copy it if its associated node is somewhere in the tree
9375 -- Note: the exclusion of self-referential copies is just an
9376 -- optimization, since the search of the already copied list
9377 -- would catch it, but it is a common case (Etype pointing
9378 -- to itself for an Itype that is a base type).
9380 elsif Has_Extension (Node_Id (F))
9381 and then Is_Itype (Entity_Id (F))
9382 and then Node_Id (F) /= N
9388 P := Associated_Node_For_Itype (Node_Id (F));
9389 while Present (P) loop
9391 Visit_Node (Node_Id (F));
9398 -- An Itype whose parent is not being copied definitely
9399 -- should NOT be copied, since it does not belong in any
9400 -- sense to the copied subtree.
9406 elsif F in List_Range
9407 and then Parent (List_Id (F)) = N
9409 Visit_List (List_Id (F));
9418 procedure Visit_Itype (Old_Itype : Entity_Id) is
9419 New_Itype : Entity_Id;
9424 -- Itypes that describe the designated type of access to subprograms
9425 -- have the structure of subprogram declarations, with signatures,
9426 -- etc. Either we duplicate the signatures completely, or choose to
9427 -- share such itypes, which is fine because their elaboration will
9428 -- have no side effects.
9430 if Ekind (Old_Itype) = E_Subprogram_Type then
9434 New_Itype := New_Copy (Old_Itype);
9436 -- The new Itype has all the attributes of the old one, and
9437 -- we just copy the contents of the entity. However, the back-end
9438 -- needs different names for debugging purposes, so we create a
9439 -- new internal name for it in all cases.
9441 Set_Chars (New_Itype, New_Internal_Name ('T'));
9443 -- If our associated node is an entity that has already been copied,
9444 -- then set the associated node of the copy to point to the right
9445 -- copy. If we have copied an Itype that is itself the associated
9446 -- node of some previously copied Itype, then we set the right
9447 -- pointer in the other direction.
9449 if Present (Actual_Map) then
9451 -- Case of hash tables used
9453 if NCT_Hash_Tables_Used then
9455 Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
9457 if Present (Ent) then
9458 Set_Associated_Node_For_Itype (New_Itype, Ent);
9461 Ent := NCT_Itype_Assoc.Get (Old_Itype);
9462 if Present (Ent) then
9463 Set_Associated_Node_For_Itype (Ent, New_Itype);
9465 -- If the hash table has no association for this Itype and
9466 -- its associated node, enter one now.
9470 (Associated_Node_For_Itype (Old_Itype), New_Itype);
9473 -- Case of hash tables not used
9476 E := First_Elmt (Actual_Map);
9477 while Present (E) loop
9478 if Associated_Node_For_Itype (Old_Itype) = Node (E) then
9479 Set_Associated_Node_For_Itype
9480 (New_Itype, Node (Next_Elmt (E)));
9483 if Is_Type (Node (E))
9485 Old_Itype = Associated_Node_For_Itype (Node (E))
9487 Set_Associated_Node_For_Itype
9488 (Node (Next_Elmt (E)), New_Itype);
9491 E := Next_Elmt (Next_Elmt (E));
9496 if Present (Freeze_Node (New_Itype)) then
9497 Set_Is_Frozen (New_Itype, False);
9498 Set_Freeze_Node (New_Itype, Empty);
9501 -- Add new association to map
9503 if No (Actual_Map) then
9504 Actual_Map := New_Elmt_List;
9507 Append_Elmt (Old_Itype, Actual_Map);
9508 Append_Elmt (New_Itype, Actual_Map);
9510 if NCT_Hash_Tables_Used then
9511 NCT_Assoc.Set (Old_Itype, New_Itype);
9514 NCT_Table_Entries := NCT_Table_Entries + 1;
9516 if NCT_Table_Entries > NCT_Hash_Threshold then
9517 Build_NCT_Hash_Tables;
9521 -- If a record subtype is simply copied, the entity list will be
9522 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
9524 if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
9525 Set_Cloned_Subtype (New_Itype, Old_Itype);
9528 -- Visit descendents that eventually get copied
9530 Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
9532 if Is_Discrete_Type (Old_Itype) then
9533 Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
9535 elsif Has_Discriminants (Base_Type (Old_Itype)) then
9536 -- ??? This should involve call to Visit_Field
9537 Visit_Elist (Discriminant_Constraint (Old_Itype));
9539 elsif Is_Array_Type (Old_Itype) then
9540 if Present (First_Index (Old_Itype)) then
9541 Visit_Field (Union_Id (List_Containing
9542 (First_Index (Old_Itype))),
9546 if Is_Packed (Old_Itype) then
9547 Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
9557 procedure Visit_List (L : List_Id) is
9560 if L /= No_List then
9563 while Present (N) loop
9574 procedure Visit_Node (N : Node_Or_Entity_Id) is
9576 -- Start of processing for Visit_Node
9579 -- Handle case of an Itype, which must be copied
9581 if Has_Extension (N)
9582 and then Is_Itype (N)
9584 -- Nothing to do if already in the list. This can happen with an
9585 -- Itype entity that appears more than once in the tree.
9586 -- Note that we do not want to visit descendents in this case.
9588 -- Test for already in list when hash table is used
9590 if NCT_Hash_Tables_Used then
9591 if Present (NCT_Assoc.Get (Entity_Id (N))) then
9595 -- Test for already in list when hash table not used
9601 if Present (Actual_Map) then
9602 E := First_Elmt (Actual_Map);
9603 while Present (E) loop
9604 if Node (E) = N then
9607 E := Next_Elmt (Next_Elmt (E));
9617 -- Visit descendents
9619 Visit_Field (Field1 (N), N);
9620 Visit_Field (Field2 (N), N);
9621 Visit_Field (Field3 (N), N);
9622 Visit_Field (Field4 (N), N);
9623 Visit_Field (Field5 (N), N);
9626 -- Start of processing for New_Copy_Tree
9631 -- See if we should use hash table
9633 if No (Actual_Map) then
9634 NCT_Hash_Tables_Used := False;
9641 NCT_Table_Entries := 0;
9643 Elmt := First_Elmt (Actual_Map);
9644 while Present (Elmt) loop
9645 NCT_Table_Entries := NCT_Table_Entries + 1;
9650 if NCT_Table_Entries > NCT_Hash_Threshold then
9651 Build_NCT_Hash_Tables;
9653 NCT_Hash_Tables_Used := False;
9658 -- Hash table set up if required, now start phase one by visiting
9659 -- top node (we will recursively visit the descendents).
9661 Visit_Node (Source);
9663 -- Now the second phase of the copy can start. First we process
9664 -- all the mapped entities, copying their descendents.
9666 if Present (Actual_Map) then
9669 New_Itype : Entity_Id;
9671 Elmt := First_Elmt (Actual_Map);
9672 while Present (Elmt) loop
9674 New_Itype := Node (Elmt);
9675 Copy_Itype_With_Replacement (New_Itype);
9681 -- Now we can copy the actual tree
9683 return Copy_Node_With_Replacement (Source);
9686 -------------------------
9687 -- New_External_Entity --
9688 -------------------------
9690 function New_External_Entity
9691 (Kind : Entity_Kind;
9692 Scope_Id : Entity_Id;
9693 Sloc_Value : Source_Ptr;
9694 Related_Id : Entity_Id;
9696 Suffix_Index : Nat := 0;
9697 Prefix : Character := ' ') return Entity_Id
9699 N : constant Entity_Id :=
9700 Make_Defining_Identifier (Sloc_Value,
9702 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
9705 Set_Ekind (N, Kind);
9706 Set_Is_Internal (N, True);
9707 Append_Entity (N, Scope_Id);
9708 Set_Public_Status (N);
9710 if Kind in Type_Kind then
9711 Init_Size_Align (N);
9715 end New_External_Entity;
9717 -------------------------
9718 -- New_Internal_Entity --
9719 -------------------------
9721 function New_Internal_Entity
9722 (Kind : Entity_Kind;
9723 Scope_Id : Entity_Id;
9724 Sloc_Value : Source_Ptr;
9725 Id_Char : Character) return Entity_Id
9727 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
9730 Set_Ekind (N, Kind);
9731 Set_Is_Internal (N, True);
9732 Append_Entity (N, Scope_Id);
9734 if Kind in Type_Kind then
9735 Init_Size_Align (N);
9739 end New_Internal_Entity;
9745 function Next_Actual (Actual_Id : Node_Id) return Node_Id is
9749 -- If we are pointing at a positional parameter, it is a member of a
9750 -- node list (the list of parameters), and the next parameter is the
9751 -- next node on the list, unless we hit a parameter association, then
9752 -- we shift to using the chain whose head is the First_Named_Actual in
9753 -- the parent, and then is threaded using the Next_Named_Actual of the
9754 -- Parameter_Association. All this fiddling is because the original node
9755 -- list is in the textual call order, and what we need is the
9756 -- declaration order.
9758 if Is_List_Member (Actual_Id) then
9759 N := Next (Actual_Id);
9761 if Nkind (N) = N_Parameter_Association then
9762 return First_Named_Actual (Parent (Actual_Id));
9768 return Next_Named_Actual (Parent (Actual_Id));
9772 procedure Next_Actual (Actual_Id : in out Node_Id) is
9774 Actual_Id := Next_Actual (Actual_Id);
9777 -----------------------
9778 -- Normalize_Actuals --
9779 -----------------------
9781 -- Chain actuals according to formals of subprogram. If there are no named
9782 -- associations, the chain is simply the list of Parameter Associations,
9783 -- since the order is the same as the declaration order. If there are named
9784 -- associations, then the First_Named_Actual field in the N_Function_Call
9785 -- or N_Procedure_Call_Statement node points to the Parameter_Association
9786 -- node for the parameter that comes first in declaration order. The
9787 -- remaining named parameters are then chained in declaration order using
9788 -- Next_Named_Actual.
9790 -- This routine also verifies that the number of actuals is compatible with
9791 -- the number and default values of formals, but performs no type checking
9792 -- (type checking is done by the caller).
9794 -- If the matching succeeds, Success is set to True and the caller proceeds
9795 -- with type-checking. If the match is unsuccessful, then Success is set to
9796 -- False, and the caller attempts a different interpretation, if there is
9799 -- If the flag Report is on, the call is not overloaded, and a failure to
9800 -- match can be reported here, rather than in the caller.
9802 procedure Normalize_Actuals
9806 Success : out Boolean)
9808 Actuals : constant List_Id := Parameter_Associations (N);
9809 Actual : Node_Id := Empty;
9811 Last : Node_Id := Empty;
9812 First_Named : Node_Id := Empty;
9815 Formals_To_Match : Integer := 0;
9816 Actuals_To_Match : Integer := 0;
9818 procedure Chain (A : Node_Id);
9819 -- Add named actual at the proper place in the list, using the
9820 -- Next_Named_Actual link.
9822 function Reporting return Boolean;
9823 -- Determines if an error is to be reported. To report an error, we
9824 -- need Report to be True, and also we do not report errors caused
9825 -- by calls to init procs that occur within other init procs. Such
9826 -- errors must always be cascaded errors, since if all the types are
9827 -- declared correctly, the compiler will certainly build decent calls!
9833 procedure Chain (A : Node_Id) is
9837 -- Call node points to first actual in list
9839 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
9842 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
9846 Set_Next_Named_Actual (Last, Empty);
9853 function Reporting return Boolean is
9858 elsif not Within_Init_Proc then
9861 elsif Is_Init_Proc (Entity (Name (N))) then
9869 -- Start of processing for Normalize_Actuals
9872 if Is_Access_Type (S) then
9874 -- The name in the call is a function call that returns an access
9875 -- to subprogram. The designated type has the list of formals.
9877 Formal := First_Formal (Designated_Type (S));
9879 Formal := First_Formal (S);
9882 while Present (Formal) loop
9883 Formals_To_Match := Formals_To_Match + 1;
9884 Next_Formal (Formal);
9887 -- Find if there is a named association, and verify that no positional
9888 -- associations appear after named ones.
9890 if Present (Actuals) then
9891 Actual := First (Actuals);
9894 while Present (Actual)
9895 and then Nkind (Actual) /= N_Parameter_Association
9897 Actuals_To_Match := Actuals_To_Match + 1;
9901 if No (Actual) and Actuals_To_Match = Formals_To_Match then
9903 -- Most common case: positional notation, no defaults
9908 elsif Actuals_To_Match > Formals_To_Match then
9910 -- Too many actuals: will not work
9913 if Is_Entity_Name (Name (N)) then
9914 Error_Msg_N ("too many arguments in call to&", Name (N));
9916 Error_Msg_N ("too many arguments in call", N);
9924 First_Named := Actual;
9926 while Present (Actual) loop
9927 if Nkind (Actual) /= N_Parameter_Association then
9929 ("positional parameters not allowed after named ones", Actual);
9934 Actuals_To_Match := Actuals_To_Match + 1;
9940 if Present (Actuals) then
9941 Actual := First (Actuals);
9944 Formal := First_Formal (S);
9945 while Present (Formal) loop
9947 -- Match the formals in order. If the corresponding actual is
9948 -- positional, nothing to do. Else scan the list of named actuals
9949 -- to find the one with the right name.
9952 and then Nkind (Actual) /= N_Parameter_Association
9955 Actuals_To_Match := Actuals_To_Match - 1;
9956 Formals_To_Match := Formals_To_Match - 1;
9959 -- For named parameters, search the list of actuals to find
9960 -- one that matches the next formal name.
9962 Actual := First_Named;
9964 while Present (Actual) loop
9965 if Chars (Selector_Name (Actual)) = Chars (Formal) then
9968 Actuals_To_Match := Actuals_To_Match - 1;
9969 Formals_To_Match := Formals_To_Match - 1;
9977 if Ekind (Formal) /= E_In_Parameter
9978 or else No (Default_Value (Formal))
9981 if (Comes_From_Source (S)
9982 or else Sloc (S) = Standard_Location)
9983 and then Is_Overloadable (S)
9987 (Nkind (Parent (N)) = N_Procedure_Call_Statement
9989 (Nkind (Parent (N)) = N_Function_Call
9991 Nkind (Parent (N)) = N_Parameter_Association))
9992 and then Ekind (S) /= E_Function
9994 Set_Etype (N, Etype (S));
9996 Error_Msg_Name_1 := Chars (S);
9997 Error_Msg_Sloc := Sloc (S);
9999 ("missing argument for parameter & " &
10000 "in call to % declared #", N, Formal);
10003 elsif Is_Overloadable (S) then
10004 Error_Msg_Name_1 := Chars (S);
10006 -- Point to type derivation that generated the
10009 Error_Msg_Sloc := Sloc (Parent (S));
10012 ("missing argument for parameter & " &
10013 "in call to % (inherited) #", N, Formal);
10017 ("missing argument for parameter &", N, Formal);
10025 Formals_To_Match := Formals_To_Match - 1;
10030 Next_Formal (Formal);
10033 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
10040 -- Find some superfluous named actual that did not get
10041 -- attached to the list of associations.
10043 Actual := First (Actuals);
10044 while Present (Actual) loop
10045 if Nkind (Actual) = N_Parameter_Association
10046 and then Actual /= Last
10047 and then No (Next_Named_Actual (Actual))
10049 Error_Msg_N ("unmatched actual & in call",
10050 Selector_Name (Actual));
10061 end Normalize_Actuals;
10063 --------------------------------
10064 -- Note_Possible_Modification --
10065 --------------------------------
10067 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
10068 Modification_Comes_From_Source : constant Boolean :=
10069 Comes_From_Source (Parent (N));
10075 -- Loop to find referenced entity, if there is one
10082 if Is_Entity_Name (Exp) then
10083 Ent := Entity (Exp);
10085 -- If the entity is missing, it is an undeclared identifier,
10086 -- and there is nothing to annotate.
10092 elsif Nkind (Exp) = N_Explicit_Dereference then
10094 P : constant Node_Id := Prefix (Exp);
10097 if Nkind (P) = N_Selected_Component
10099 Entry_Formal (Entity (Selector_Name (P))))
10101 -- Case of a reference to an entry formal
10103 Ent := Entry_Formal (Entity (Selector_Name (P)));
10105 elsif Nkind (P) = N_Identifier
10106 and then Nkind (Parent (Entity (P))) = N_Object_Declaration
10107 and then Present (Expression (Parent (Entity (P))))
10108 and then Nkind (Expression (Parent (Entity (P))))
10111 -- Case of a reference to a value on which side effects have
10114 Exp := Prefix (Expression (Parent (Entity (P))));
10123 elsif Nkind (Exp) = N_Type_Conversion
10124 or else Nkind (Exp) = N_Unchecked_Type_Conversion
10126 Exp := Expression (Exp);
10129 elsif Nkind (Exp) = N_Slice
10130 or else Nkind (Exp) = N_Indexed_Component
10131 or else Nkind (Exp) = N_Selected_Component
10133 Exp := Prefix (Exp);
10140 -- Now look for entity being referenced
10142 if Present (Ent) then
10143 if Is_Object (Ent) then
10144 if Comes_From_Source (Exp)
10145 or else Modification_Comes_From_Source
10147 -- Give warning if pragma unmodified given and we are
10148 -- sure this is a modification.
10150 if Has_Pragma_Unmodified (Ent) and then Sure then
10151 Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
10154 Set_Never_Set_In_Source (Ent, False);
10157 Set_Is_True_Constant (Ent, False);
10158 Set_Current_Value (Ent, Empty);
10159 Set_Is_Known_Null (Ent, False);
10161 if not Can_Never_Be_Null (Ent) then
10162 Set_Is_Known_Non_Null (Ent, False);
10165 -- Follow renaming chain
10167 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
10168 and then Present (Renamed_Object (Ent))
10170 Exp := Renamed_Object (Ent);
10174 -- Generate a reference only if the assignment comes from
10175 -- source. This excludes, for example, calls to a dispatching
10176 -- assignment operation when the left-hand side is tagged.
10178 if Modification_Comes_From_Source then
10179 Generate_Reference (Ent, Exp, 'm');
10181 -- If the target of the assignment is the bound variable
10182 -- in an iterator, indicate that the corresponding array
10183 -- or container is also modified.
10185 if Ada_Version >= Ada_2012
10187 Nkind (Parent (Ent)) = N_Iterator_Specification
10190 Domain : constant Node_Id := Name (Parent (Ent));
10193 -- TBD : in the full version of the construct, the
10194 -- domain of iteration can be given by an expression.
10196 if Is_Entity_Name (Domain) then
10197 Generate_Reference (Entity (Domain), Exp, 'm');
10198 Set_Is_True_Constant (Entity (Domain), False);
10199 Set_Never_Set_In_Source (Entity (Domain), False);
10205 Check_Nested_Access (Ent);
10210 -- If we are sure this is a modification from source, and we know
10211 -- this modifies a constant, then give an appropriate warning.
10213 if Overlays_Constant (Ent)
10214 and then Modification_Comes_From_Source
10218 A : constant Node_Id := Address_Clause (Ent);
10220 if Present (A) then
10222 Exp : constant Node_Id := Expression (A);
10224 if Nkind (Exp) = N_Attribute_Reference
10225 and then Attribute_Name (Exp) = Name_Address
10226 and then Is_Entity_Name (Prefix (Exp))
10228 Error_Msg_Sloc := Sloc (A);
10230 ("constant& may be modified via address clause#?",
10231 N, Entity (Prefix (Exp)));
10241 end Note_Possible_Modification;
10243 -------------------------
10244 -- Object_Access_Level --
10245 -------------------------
10247 function Object_Access_Level (Obj : Node_Id) return Uint is
10250 -- Returns the static accessibility level of the view denoted by Obj. Note
10251 -- that the value returned is the result of a call to Scope_Depth. Only
10252 -- scope depths associated with dynamic scopes can actually be returned.
10253 -- Since only relative levels matter for accessibility checking, the fact
10254 -- that the distance between successive levels of accessibility is not
10255 -- always one is immaterial (invariant: if level(E2) is deeper than
10256 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
10258 function Reference_To (Obj : Node_Id) return Node_Id;
10259 -- An explicit dereference is created when removing side-effects from
10260 -- expressions for constraint checking purposes. In this case a local
10261 -- access type is created for it. The correct access level is that of
10262 -- the original source node. We detect this case by noting that the
10263 -- prefix of the dereference is created by an object declaration whose
10264 -- initial expression is a reference.
10270 function Reference_To (Obj : Node_Id) return Node_Id is
10271 Pref : constant Node_Id := Prefix (Obj);
10273 if Is_Entity_Name (Pref)
10274 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
10275 and then Present (Expression (Parent (Entity (Pref))))
10276 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
10278 return (Prefix (Expression (Parent (Entity (Pref)))));
10284 -- Start of processing for Object_Access_Level
10287 if Is_Entity_Name (Obj) then
10290 if Is_Prival (E) then
10291 E := Prival_Link (E);
10294 -- If E is a type then it denotes a current instance. For this case
10295 -- we add one to the normal accessibility level of the type to ensure
10296 -- that current instances are treated as always being deeper than
10297 -- than the level of any visible named access type (see 3.10.2(21)).
10299 if Is_Type (E) then
10300 return Type_Access_Level (E) + 1;
10302 elsif Present (Renamed_Object (E)) then
10303 return Object_Access_Level (Renamed_Object (E));
10305 -- Similarly, if E is a component of the current instance of a
10306 -- protected type, any instance of it is assumed to be at a deeper
10307 -- level than the type. For a protected object (whose type is an
10308 -- anonymous protected type) its components are at the same level
10309 -- as the type itself.
10311 elsif not Is_Overloadable (E)
10312 and then Ekind (Scope (E)) = E_Protected_Type
10313 and then Comes_From_Source (Scope (E))
10315 return Type_Access_Level (Scope (E)) + 1;
10318 return Scope_Depth (Enclosing_Dynamic_Scope (E));
10321 elsif Nkind (Obj) = N_Selected_Component then
10322 if Is_Access_Type (Etype (Prefix (Obj))) then
10323 return Type_Access_Level (Etype (Prefix (Obj)));
10325 return Object_Access_Level (Prefix (Obj));
10328 elsif Nkind (Obj) = N_Indexed_Component then
10329 if Is_Access_Type (Etype (Prefix (Obj))) then
10330 return Type_Access_Level (Etype (Prefix (Obj)));
10332 return Object_Access_Level (Prefix (Obj));
10335 elsif Nkind (Obj) = N_Explicit_Dereference then
10337 -- If the prefix is a selected access discriminant then we make a
10338 -- recursive call on the prefix, which will in turn check the level
10339 -- of the prefix object of the selected discriminant.
10341 if Nkind (Prefix (Obj)) = N_Selected_Component
10342 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
10344 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
10346 return Object_Access_Level (Prefix (Obj));
10348 elsif not (Comes_From_Source (Obj)) then
10350 Ref : constant Node_Id := Reference_To (Obj);
10352 if Present (Ref) then
10353 return Object_Access_Level (Ref);
10355 return Type_Access_Level (Etype (Prefix (Obj)));
10360 return Type_Access_Level (Etype (Prefix (Obj)));
10363 elsif Nkind (Obj) = N_Type_Conversion
10364 or else Nkind (Obj) = N_Unchecked_Type_Conversion
10366 return Object_Access_Level (Expression (Obj));
10368 elsif Nkind (Obj) = N_Function_Call then
10370 -- Function results are objects, so we get either the access level of
10371 -- the function or, in the case of an indirect call, the level of the
10372 -- access-to-subprogram type. (This code is used for Ada 95, but it
10373 -- looks wrong, because it seems that we should be checking the level
10374 -- of the call itself, even for Ada 95. However, using the Ada 2005
10375 -- version of the code causes regressions in several tests that are
10376 -- compiled with -gnat95. ???)
10378 if Ada_Version < Ada_2005 then
10379 if Is_Entity_Name (Name (Obj)) then
10380 return Subprogram_Access_Level (Entity (Name (Obj)));
10382 return Type_Access_Level (Etype (Prefix (Name (Obj))));
10385 -- For Ada 2005, the level of the result object of a function call is
10386 -- defined to be the level of the call's innermost enclosing master.
10387 -- We determine that by querying the depth of the innermost enclosing
10391 Return_Master_Scope_Depth_Of_Call : declare
10393 function Innermost_Master_Scope_Depth
10394 (N : Node_Id) return Uint;
10395 -- Returns the scope depth of the given node's innermost
10396 -- enclosing dynamic scope (effectively the accessibility
10397 -- level of the innermost enclosing master).
10399 ----------------------------------
10400 -- Innermost_Master_Scope_Depth --
10401 ----------------------------------
10403 function Innermost_Master_Scope_Depth
10404 (N : Node_Id) return Uint
10406 Node_Par : Node_Id := Parent (N);
10409 -- Locate the nearest enclosing node (by traversing Parents)
10410 -- that Defining_Entity can be applied to, and return the
10411 -- depth of that entity's nearest enclosing dynamic scope.
10413 while Present (Node_Par) loop
10414 case Nkind (Node_Par) is
10415 when N_Component_Declaration |
10416 N_Entry_Declaration |
10417 N_Formal_Object_Declaration |
10418 N_Formal_Type_Declaration |
10419 N_Full_Type_Declaration |
10420 N_Incomplete_Type_Declaration |
10421 N_Loop_Parameter_Specification |
10422 N_Object_Declaration |
10423 N_Protected_Type_Declaration |
10424 N_Private_Extension_Declaration |
10425 N_Private_Type_Declaration |
10426 N_Subtype_Declaration |
10427 N_Function_Specification |
10428 N_Procedure_Specification |
10429 N_Task_Type_Declaration |
10431 N_Generic_Instantiation |
10433 N_Implicit_Label_Declaration |
10434 N_Package_Declaration |
10435 N_Single_Task_Declaration |
10436 N_Subprogram_Declaration |
10437 N_Generic_Declaration |
10438 N_Renaming_Declaration |
10439 N_Block_Statement |
10440 N_Formal_Subprogram_Declaration |
10441 N_Abstract_Subprogram_Declaration |
10443 N_Exception_Declaration |
10444 N_Formal_Package_Declaration |
10445 N_Number_Declaration |
10446 N_Package_Specification |
10447 N_Parameter_Specification |
10448 N_Single_Protected_Declaration |
10452 (Nearest_Dynamic_Scope
10453 (Defining_Entity (Node_Par)));
10459 Node_Par := Parent (Node_Par);
10462 pragma Assert (False);
10464 -- Should never reach the following return
10466 return Scope_Depth (Current_Scope) + 1;
10467 end Innermost_Master_Scope_Depth;
10469 -- Start of processing for Return_Master_Scope_Depth_Of_Call
10472 return Innermost_Master_Scope_Depth (Obj);
10473 end Return_Master_Scope_Depth_Of_Call;
10476 -- For convenience we handle qualified expressions, even though
10477 -- they aren't technically object names.
10479 elsif Nkind (Obj) = N_Qualified_Expression then
10480 return Object_Access_Level (Expression (Obj));
10482 -- Otherwise return the scope level of Standard.
10483 -- (If there are cases that fall through
10484 -- to this point they will be treated as
10485 -- having global accessibility for now. ???)
10488 return Scope_Depth (Standard_Standard);
10490 end Object_Access_Level;
10492 --------------------------------------
10493 -- Original_Corresponding_Operation --
10494 --------------------------------------
10496 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
10498 Typ : constant Entity_Id := Find_Dispatching_Type (S);
10501 -- If S is an inherited primitive S2 the original corresponding
10502 -- operation of S is the original corresponding operation of S2
10504 if Present (Alias (S))
10505 and then Find_Dispatching_Type (Alias (S)) /= Typ
10507 return Original_Corresponding_Operation (Alias (S));
10509 -- If S overrides an inherited subprogram S2 the original corresponding
10510 -- operation of S is the original corresponding operation of S2
10512 elsif Present (Overridden_Operation (S)) then
10513 return Original_Corresponding_Operation (Overridden_Operation (S));
10515 -- otherwise it is S itself
10520 end Original_Corresponding_Operation;
10522 -----------------------
10523 -- Private_Component --
10524 -----------------------
10526 function Private_Component (Type_Id : Entity_Id) return Entity_Id is
10527 Ancestor : constant Entity_Id := Base_Type (Type_Id);
10529 function Trace_Components
10531 Check : Boolean) return Entity_Id;
10532 -- Recursive function that does the work, and checks against circular
10533 -- definition for each subcomponent type.
10535 ----------------------
10536 -- Trace_Components --
10537 ----------------------
10539 function Trace_Components
10541 Check : Boolean) return Entity_Id
10543 Btype : constant Entity_Id := Base_Type (T);
10544 Component : Entity_Id;
10546 Candidate : Entity_Id := Empty;
10549 if Check and then Btype = Ancestor then
10550 Error_Msg_N ("circular type definition", Type_Id);
10554 if Is_Private_Type (Btype)
10555 and then not Is_Generic_Type (Btype)
10557 if Present (Full_View (Btype))
10558 and then Is_Record_Type (Full_View (Btype))
10559 and then not Is_Frozen (Btype)
10561 -- To indicate that the ancestor depends on a private type, the
10562 -- current Btype is sufficient. However, to check for circular
10563 -- definition we must recurse on the full view.
10565 Candidate := Trace_Components (Full_View (Btype), True);
10567 if Candidate = Any_Type then
10577 elsif Is_Array_Type (Btype) then
10578 return Trace_Components (Component_Type (Btype), True);
10580 elsif Is_Record_Type (Btype) then
10581 Component := First_Entity (Btype);
10582 while Present (Component) loop
10584 -- Skip anonymous types generated by constrained components
10586 if not Is_Type (Component) then
10587 P := Trace_Components (Etype (Component), True);
10589 if Present (P) then
10590 if P = Any_Type then
10598 Next_Entity (Component);
10606 end Trace_Components;
10608 -- Start of processing for Private_Component
10611 return Trace_Components (Type_Id, False);
10612 end Private_Component;
10614 ---------------------------
10615 -- Primitive_Names_Match --
10616 ---------------------------
10618 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
10620 function Non_Internal_Name (E : Entity_Id) return Name_Id;
10621 -- Given an internal name, returns the corresponding non-internal name
10623 ------------------------
10624 -- Non_Internal_Name --
10625 ------------------------
10627 function Non_Internal_Name (E : Entity_Id) return Name_Id is
10629 Get_Name_String (Chars (E));
10630 Name_Len := Name_Len - 1;
10632 end Non_Internal_Name;
10634 -- Start of processing for Primitive_Names_Match
10637 pragma Assert (Present (E1) and then Present (E2));
10639 return Chars (E1) = Chars (E2)
10641 (not Is_Internal_Name (Chars (E1))
10642 and then Is_Internal_Name (Chars (E2))
10643 and then Non_Internal_Name (E2) = Chars (E1))
10645 (not Is_Internal_Name (Chars (E2))
10646 and then Is_Internal_Name (Chars (E1))
10647 and then Non_Internal_Name (E1) = Chars (E2))
10649 (Is_Predefined_Dispatching_Operation (E1)
10650 and then Is_Predefined_Dispatching_Operation (E2)
10651 and then Same_TSS (E1, E2))
10653 (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
10654 end Primitive_Names_Match;
10656 -----------------------
10657 -- Process_End_Label --
10658 -----------------------
10660 procedure Process_End_Label
10669 Label_Ref : Boolean;
10670 -- Set True if reference to end label itself is required
10673 -- Gets set to the operator symbol or identifier that references the
10674 -- entity Ent. For the child unit case, this is the identifier from the
10675 -- designator. For other cases, this is simply Endl.
10677 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
10678 -- N is an identifier node that appears as a parent unit reference in
10679 -- the case where Ent is a child unit. This procedure generates an
10680 -- appropriate cross-reference entry. E is the corresponding entity.
10682 -------------------------
10683 -- Generate_Parent_Ref --
10684 -------------------------
10686 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
10688 -- If names do not match, something weird, skip reference
10690 if Chars (E) = Chars (N) then
10692 -- Generate the reference. We do NOT consider this as a reference
10693 -- for unreferenced symbol purposes.
10695 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
10697 if Style_Check then
10698 Style.Check_Identifier (N, E);
10701 end Generate_Parent_Ref;
10703 -- Start of processing for Process_End_Label
10706 -- If no node, ignore. This happens in some error situations, and
10707 -- also for some internally generated structures where no end label
10708 -- references are required in any case.
10714 -- Nothing to do if no End_Label, happens for internally generated
10715 -- constructs where we don't want an end label reference anyway. Also
10716 -- nothing to do if Endl is a string literal, which means there was
10717 -- some prior error (bad operator symbol)
10719 Endl := End_Label (N);
10721 if No (Endl) or else Nkind (Endl) = N_String_Literal then
10725 -- Reference node is not in extended main source unit
10727 if not In_Extended_Main_Source_Unit (N) then
10729 -- Generally we do not collect references except for the extended
10730 -- main source unit. The one exception is the 'e' entry for a
10731 -- package spec, where it is useful for a client to have the
10732 -- ending information to define scopes.
10738 Label_Ref := False;
10740 -- For this case, we can ignore any parent references, but we
10741 -- need the package name itself for the 'e' entry.
10743 if Nkind (Endl) = N_Designator then
10744 Endl := Identifier (Endl);
10748 -- Reference is in extended main source unit
10753 -- For designator, generate references for the parent entries
10755 if Nkind (Endl) = N_Designator then
10757 -- Generate references for the prefix if the END line comes from
10758 -- source (otherwise we do not need these references) We climb the
10759 -- scope stack to find the expected entities.
10761 if Comes_From_Source (Endl) then
10762 Nam := Name (Endl);
10763 Scop := Current_Scope;
10764 while Nkind (Nam) = N_Selected_Component loop
10765 Scop := Scope (Scop);
10766 exit when No (Scop);
10767 Generate_Parent_Ref (Selector_Name (Nam), Scop);
10768 Nam := Prefix (Nam);
10771 if Present (Scop) then
10772 Generate_Parent_Ref (Nam, Scope (Scop));
10776 Endl := Identifier (Endl);
10780 -- If the end label is not for the given entity, then either we have
10781 -- some previous error, or this is a generic instantiation for which
10782 -- we do not need to make a cross-reference in this case anyway. In
10783 -- either case we simply ignore the call.
10785 if Chars (Ent) /= Chars (Endl) then
10789 -- If label was really there, then generate a normal reference and then
10790 -- adjust the location in the end label to point past the name (which
10791 -- should almost always be the semicolon).
10793 Loc := Sloc (Endl);
10795 if Comes_From_Source (Endl) then
10797 -- If a label reference is required, then do the style check and
10798 -- generate an l-type cross-reference entry for the label
10801 if Style_Check then
10802 Style.Check_Identifier (Endl, Ent);
10805 Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
10808 -- Set the location to point past the label (normally this will
10809 -- mean the semicolon immediately following the label). This is
10810 -- done for the sake of the 'e' or 't' entry generated below.
10812 Get_Decoded_Name_String (Chars (Endl));
10813 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
10816 -- In SPARK mode, no missing label is allowed for packages and
10817 -- subprogram bodies. Detect those cases by testing whether
10818 -- Process_End_Label was called for a body (Typ = 't') or a package.
10820 if (SPARK_Mode or else Restriction_Check_Required (SPARK))
10821 and then (Typ = 't' or else Ekind (Ent) = E_Package)
10823 Error_Msg_Node_1 := Endl;
10824 Check_SPARK_Restriction ("`END &` required", Endl, Force => True);
10828 -- Now generate the e/t reference
10830 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
10832 -- Restore Sloc, in case modified above, since we have an identifier
10833 -- and the normal Sloc should be left set in the tree.
10835 Set_Sloc (Endl, Loc);
10836 end Process_End_Label;
10838 ------------------------------------
10839 -- References_Generic_Formal_Type --
10840 ------------------------------------
10842 function References_Generic_Formal_Type (N : Node_Id) return Boolean is
10844 function Process (N : Node_Id) return Traverse_Result;
10845 -- Process one node in search for generic formal type
10851 function Process (N : Node_Id) return Traverse_Result is
10853 if Nkind (N) in N_Has_Entity then
10855 E : constant Entity_Id := Entity (N);
10857 if Present (E) then
10858 if Is_Generic_Type (E) then
10860 elsif Present (Etype (E))
10861 and then Is_Generic_Type (Etype (E))
10872 function Traverse is new Traverse_Func (Process);
10873 -- Traverse tree to look for generic type
10876 if Inside_A_Generic then
10877 return Traverse (N) = Abandon;
10881 end References_Generic_Formal_Type;
10883 --------------------
10884 -- Remove_Homonym --
10885 --------------------
10887 procedure Remove_Homonym (E : Entity_Id) is
10888 Prev : Entity_Id := Empty;
10892 if E = Current_Entity (E) then
10893 if Present (Homonym (E)) then
10894 Set_Current_Entity (Homonym (E));
10896 Set_Name_Entity_Id (Chars (E), Empty);
10899 H := Current_Entity (E);
10900 while Present (H) and then H /= E loop
10905 Set_Homonym (Prev, Homonym (E));
10907 end Remove_Homonym;
10909 ---------------------
10910 -- Rep_To_Pos_Flag --
10911 ---------------------
10913 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
10915 return New_Occurrence_Of
10916 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
10917 end Rep_To_Pos_Flag;
10919 --------------------
10920 -- Require_Entity --
10921 --------------------
10923 procedure Require_Entity (N : Node_Id) is
10925 if Is_Entity_Name (N) and then No (Entity (N)) then
10926 if Total_Errors_Detected /= 0 then
10927 Set_Entity (N, Any_Id);
10929 raise Program_Error;
10932 end Require_Entity;
10934 ------------------------------
10935 -- Requires_Transient_Scope --
10936 ------------------------------
10938 -- A transient scope is required when variable-sized temporaries are
10939 -- allocated in the primary or secondary stack, or when finalization
10940 -- actions must be generated before the next instruction.
10942 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
10943 Typ : constant Entity_Id := Underlying_Type (Id);
10945 -- Start of processing for Requires_Transient_Scope
10948 -- This is a private type which is not completed yet. This can only
10949 -- happen in a default expression (of a formal parameter or of a
10950 -- record component). Do not expand transient scope in this case
10955 -- Do not expand transient scope for non-existent procedure return
10957 elsif Typ = Standard_Void_Type then
10960 -- Elementary types do not require a transient scope
10962 elsif Is_Elementary_Type (Typ) then
10965 -- Generally, indefinite subtypes require a transient scope, since the
10966 -- back end cannot generate temporaries, since this is not a valid type
10967 -- for declaring an object. It might be possible to relax this in the
10968 -- future, e.g. by declaring the maximum possible space for the type.
10970 elsif Is_Indefinite_Subtype (Typ) then
10973 -- Functions returning tagged types may dispatch on result so their
10974 -- returned value is allocated on the secondary stack. Controlled
10975 -- type temporaries need finalization.
10977 elsif Is_Tagged_Type (Typ)
10978 or else Has_Controlled_Component (Typ)
10980 return not Is_Value_Type (Typ);
10984 elsif Is_Record_Type (Typ) then
10988 Comp := First_Entity (Typ);
10989 while Present (Comp) loop
10990 if Ekind (Comp) = E_Component
10991 and then Requires_Transient_Scope (Etype (Comp))
10995 Next_Entity (Comp);
11002 -- String literal types never require transient scope
11004 elsif Ekind (Typ) = E_String_Literal_Subtype then
11007 -- Array type. Note that we already know that this is a constrained
11008 -- array, since unconstrained arrays will fail the indefinite test.
11010 elsif Is_Array_Type (Typ) then
11012 -- If component type requires a transient scope, the array does too
11014 if Requires_Transient_Scope (Component_Type (Typ)) then
11017 -- Otherwise, we only need a transient scope if the size depends on
11018 -- the value of one or more discriminants.
11021 return Size_Depends_On_Discriminant (Typ);
11024 -- All other cases do not require a transient scope
11029 end Requires_Transient_Scope;
11031 --------------------------
11032 -- Reset_Analyzed_Flags --
11033 --------------------------
11035 procedure Reset_Analyzed_Flags (N : Node_Id) is
11037 function Clear_Analyzed (N : Node_Id) return Traverse_Result;
11038 -- Function used to reset Analyzed flags in tree. Note that we do
11039 -- not reset Analyzed flags in entities, since there is no need to
11040 -- reanalyze entities, and indeed, it is wrong to do so, since it
11041 -- can result in generating auxiliary stuff more than once.
11043 --------------------
11044 -- Clear_Analyzed --
11045 --------------------
11047 function Clear_Analyzed (N : Node_Id) return Traverse_Result is
11049 if not Has_Extension (N) then
11050 Set_Analyzed (N, False);
11054 end Clear_Analyzed;
11056 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
11058 -- Start of processing for Reset_Analyzed_Flags
11061 Reset_Analyzed (N);
11062 end Reset_Analyzed_Flags;
11064 ---------------------------
11065 -- Safe_To_Capture_Value --
11066 ---------------------------
11068 function Safe_To_Capture_Value
11071 Cond : Boolean := False) return Boolean
11074 -- The only entities for which we track constant values are variables
11075 -- which are not renamings, constants, out parameters, and in out
11076 -- parameters, so check if we have this case.
11078 -- Note: it may seem odd to track constant values for constants, but in
11079 -- fact this routine is used for other purposes than simply capturing
11080 -- the value. In particular, the setting of Known[_Non]_Null.
11082 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
11084 Ekind (Ent) = E_Constant
11086 Ekind (Ent) = E_Out_Parameter
11088 Ekind (Ent) = E_In_Out_Parameter
11092 -- For conditionals, we also allow loop parameters and all formals,
11093 -- including in parameters.
11097 (Ekind (Ent) = E_Loop_Parameter
11099 Ekind (Ent) = E_In_Parameter)
11103 -- For all other cases, not just unsafe, but impossible to capture
11104 -- Current_Value, since the above are the only entities which have
11105 -- Current_Value fields.
11111 -- Skip if volatile or aliased, since funny things might be going on in
11112 -- these cases which we cannot necessarily track. Also skip any variable
11113 -- for which an address clause is given, or whose address is taken. Also
11114 -- never capture value of library level variables (an attempt to do so
11115 -- can occur in the case of package elaboration code).
11117 if Treat_As_Volatile (Ent)
11118 or else Is_Aliased (Ent)
11119 or else Present (Address_Clause (Ent))
11120 or else Address_Taken (Ent)
11121 or else (Is_Library_Level_Entity (Ent)
11122 and then Ekind (Ent) = E_Variable)
11127 -- OK, all above conditions are met. We also require that the scope of
11128 -- the reference be the same as the scope of the entity, not counting
11129 -- packages and blocks and loops.
11132 E_Scope : constant Entity_Id := Scope (Ent);
11133 R_Scope : Entity_Id;
11136 R_Scope := Current_Scope;
11137 while R_Scope /= Standard_Standard loop
11138 exit when R_Scope = E_Scope;
11140 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
11143 R_Scope := Scope (R_Scope);
11148 -- We also require that the reference does not appear in a context
11149 -- where it is not sure to be executed (i.e. a conditional context
11150 -- or an exception handler). We skip this if Cond is True, since the
11151 -- capturing of values from conditional tests handles this ok.
11165 while Present (P) loop
11166 if Nkind (P) = N_If_Statement
11167 or else Nkind (P) = N_Case_Statement
11168 or else (Nkind (P) in N_Short_Circuit
11169 and then Desc = Right_Opnd (P))
11170 or else (Nkind (P) = N_Conditional_Expression
11171 and then Desc /= First (Expressions (P)))
11172 or else Nkind (P) = N_Exception_Handler
11173 or else Nkind (P) = N_Selective_Accept
11174 or else Nkind (P) = N_Conditional_Entry_Call
11175 or else Nkind (P) = N_Timed_Entry_Call
11176 or else Nkind (P) = N_Asynchronous_Select
11186 -- OK, looks safe to set value
11189 end Safe_To_Capture_Value;
11195 function Same_Name (N1, N2 : Node_Id) return Boolean is
11196 K1 : constant Node_Kind := Nkind (N1);
11197 K2 : constant Node_Kind := Nkind (N2);
11200 if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
11201 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
11203 return Chars (N1) = Chars (N2);
11205 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
11206 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
11208 return Same_Name (Selector_Name (N1), Selector_Name (N2))
11209 and then Same_Name (Prefix (N1), Prefix (N2));
11220 function Same_Object (Node1, Node2 : Node_Id) return Boolean is
11221 N1 : constant Node_Id := Original_Node (Node1);
11222 N2 : constant Node_Id := Original_Node (Node2);
11223 -- We do the tests on original nodes, since we are most interested
11224 -- in the original source, not any expansion that got in the way.
11226 K1 : constant Node_Kind := Nkind (N1);
11227 K2 : constant Node_Kind := Nkind (N2);
11230 -- First case, both are entities with same entity
11232 if K1 in N_Has_Entity and then K2 in N_Has_Entity then
11234 EN1 : constant Entity_Id := Entity (N1);
11235 EN2 : constant Entity_Id := Entity (N2);
11237 if Present (EN1) and then Present (EN2)
11238 and then (Ekind_In (EN1, E_Variable, E_Constant)
11239 or else Is_Formal (EN1))
11247 -- Second case, selected component with same selector, same record
11249 if K1 = N_Selected_Component
11250 and then K2 = N_Selected_Component
11251 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
11253 return Same_Object (Prefix (N1), Prefix (N2));
11255 -- Third case, indexed component with same subscripts, same array
11257 elsif K1 = N_Indexed_Component
11258 and then K2 = N_Indexed_Component
11259 and then Same_Object (Prefix (N1), Prefix (N2))
11264 E1 := First (Expressions (N1));
11265 E2 := First (Expressions (N2));
11266 while Present (E1) loop
11267 if not Same_Value (E1, E2) then
11278 -- Fourth case, slice of same array with same bounds
11281 and then K2 = N_Slice
11282 and then Nkind (Discrete_Range (N1)) = N_Range
11283 and then Nkind (Discrete_Range (N2)) = N_Range
11284 and then Same_Value (Low_Bound (Discrete_Range (N1)),
11285 Low_Bound (Discrete_Range (N2)))
11286 and then Same_Value (High_Bound (Discrete_Range (N1)),
11287 High_Bound (Discrete_Range (N2)))
11289 return Same_Name (Prefix (N1), Prefix (N2));
11291 -- All other cases, not clearly the same object
11302 function Same_Type (T1, T2 : Entity_Id) return Boolean is
11307 elsif not Is_Constrained (T1)
11308 and then not Is_Constrained (T2)
11309 and then Base_Type (T1) = Base_Type (T2)
11313 -- For now don't bother with case of identical constraints, to be
11314 -- fiddled with later on perhaps (this is only used for optimization
11315 -- purposes, so it is not critical to do a best possible job)
11326 function Same_Value (Node1, Node2 : Node_Id) return Boolean is
11328 if Compile_Time_Known_Value (Node1)
11329 and then Compile_Time_Known_Value (Node2)
11330 and then Expr_Value (Node1) = Expr_Value (Node2)
11333 elsif Same_Object (Node1, Node2) then
11344 procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is
11346 if Ada_Version < Ada_2012 then
11349 elsif Is_Entity_Name (N)
11351 Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice)
11353 (Nkind (N) = N_Attribute_Reference
11354 and then Attribute_Name (N) = Name_Access)
11357 -- We are only interested in IN OUT parameters of inner calls
11360 or else Nkind (Parent (N)) = N_Function_Call
11361 or else Nkind (Parent (N)) in N_Op
11363 Actuals_In_Call.Increment_Last;
11364 Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable);
11369 ------------------------
11370 -- Scope_Is_Transient --
11371 ------------------------
11373 function Scope_Is_Transient return Boolean is
11375 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
11376 end Scope_Is_Transient;
11382 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
11387 while Scop /= Standard_Standard loop
11388 Scop := Scope (Scop);
11390 if Scop = Scope2 then
11398 --------------------------
11399 -- Scope_Within_Or_Same --
11400 --------------------------
11402 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
11407 while Scop /= Standard_Standard loop
11408 if Scop = Scope2 then
11411 Scop := Scope (Scop);
11416 end Scope_Within_Or_Same;
11418 --------------------
11419 -- Set_Convention --
11420 --------------------
11422 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
11424 Basic_Set_Convention (E, Val);
11427 and then Is_Access_Subprogram_Type (Base_Type (E))
11428 and then Has_Foreign_Convention (E)
11430 Set_Can_Use_Internal_Rep (E, False);
11432 end Set_Convention;
11434 ------------------------
11435 -- Set_Current_Entity --
11436 ------------------------
11438 -- The given entity is to be set as the currently visible definition
11439 -- of its associated name (i.e. the Node_Id associated with its name).
11440 -- All we have to do is to get the name from the identifier, and
11441 -- then set the associated Node_Id to point to the given entity.
11443 procedure Set_Current_Entity (E : Entity_Id) is
11445 Set_Name_Entity_Id (Chars (E), E);
11446 end Set_Current_Entity;
11448 ---------------------------
11449 -- Set_Debug_Info_Needed --
11450 ---------------------------
11452 procedure Set_Debug_Info_Needed (T : Entity_Id) is
11454 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
11455 pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
11456 -- Used to set debug info in a related node if not set already
11458 --------------------------------------
11459 -- Set_Debug_Info_Needed_If_Not_Set --
11460 --------------------------------------
11462 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
11465 and then not Needs_Debug_Info (E)
11467 Set_Debug_Info_Needed (E);
11469 -- For a private type, indicate that the full view also needs
11470 -- debug information.
11473 and then Is_Private_Type (E)
11474 and then Present (Full_View (E))
11476 Set_Debug_Info_Needed (Full_View (E));
11479 end Set_Debug_Info_Needed_If_Not_Set;
11481 -- Start of processing for Set_Debug_Info_Needed
11484 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which
11485 -- indicates that Debug_Info_Needed is never required for the entity.
11488 or else Debug_Info_Off (T)
11493 -- Set flag in entity itself. Note that we will go through the following
11494 -- circuitry even if the flag is already set on T. That's intentional,
11495 -- it makes sure that the flag will be set in subsidiary entities.
11497 Set_Needs_Debug_Info (T);
11499 -- Set flag on subsidiary entities if not set already
11501 if Is_Object (T) then
11502 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
11504 elsif Is_Type (T) then
11505 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
11507 if Is_Record_Type (T) then
11509 Ent : Entity_Id := First_Entity (T);
11511 while Present (Ent) loop
11512 Set_Debug_Info_Needed_If_Not_Set (Ent);
11517 -- For a class wide subtype, we also need debug information
11518 -- for the equivalent type.
11520 if Ekind (T) = E_Class_Wide_Subtype then
11521 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
11524 elsif Is_Array_Type (T) then
11525 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
11528 Indx : Node_Id := First_Index (T);
11530 while Present (Indx) loop
11531 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
11532 Indx := Next_Index (Indx);
11536 if Is_Packed (T) then
11537 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
11540 elsif Is_Access_Type (T) then
11541 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
11543 elsif Is_Private_Type (T) then
11544 Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
11546 elsif Is_Protected_Type (T) then
11547 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
11550 end Set_Debug_Info_Needed;
11552 ---------------------------------
11553 -- Set_Entity_With_Style_Check --
11554 ---------------------------------
11556 procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
11557 Val_Actual : Entity_Id;
11561 Set_Entity (N, Val);
11564 and then not Suppress_Style_Checks (Val)
11565 and then not In_Instance
11567 if Nkind (N) = N_Identifier then
11569 elsif Nkind (N) = N_Expanded_Name then
11570 Nod := Selector_Name (N);
11575 -- A special situation arises for derived operations, where we want
11576 -- to do the check against the parent (since the Sloc of the derived
11577 -- operation points to the derived type declaration itself).
11580 while not Comes_From_Source (Val_Actual)
11581 and then Nkind (Val_Actual) in N_Entity
11582 and then (Ekind (Val_Actual) = E_Enumeration_Literal
11583 or else Is_Subprogram (Val_Actual)
11584 or else Is_Generic_Subprogram (Val_Actual))
11585 and then Present (Alias (Val_Actual))
11587 Val_Actual := Alias (Val_Actual);
11590 -- Renaming declarations for generic actuals do not come from source,
11591 -- and have a different name from that of the entity they rename, so
11592 -- there is no style check to perform here.
11594 if Chars (Nod) = Chars (Val_Actual) then
11595 Style.Check_Identifier (Nod, Val_Actual);
11599 Set_Entity (N, Val);
11600 end Set_Entity_With_Style_Check;
11602 ------------------------
11603 -- Set_Name_Entity_Id --
11604 ------------------------
11606 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
11608 Set_Name_Table_Info (Id, Int (Val));
11609 end Set_Name_Entity_Id;
11611 ---------------------
11612 -- Set_Next_Actual --
11613 ---------------------
11615 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
11617 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
11618 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
11620 end Set_Next_Actual;
11622 ----------------------------------
11623 -- Set_Optimize_Alignment_Flags --
11624 ----------------------------------
11626 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
11628 if Optimize_Alignment = 'S' then
11629 Set_Optimize_Alignment_Space (E);
11630 elsif Optimize_Alignment = 'T' then
11631 Set_Optimize_Alignment_Time (E);
11633 end Set_Optimize_Alignment_Flags;
11635 -----------------------
11636 -- Set_Public_Status --
11637 -----------------------
11639 procedure Set_Public_Status (Id : Entity_Id) is
11640 S : constant Entity_Id := Current_Scope;
11642 function Within_HSS_Or_If (E : Entity_Id) return Boolean;
11643 -- Determines if E is defined within handled statement sequence or
11644 -- an if statement, returns True if so, False otherwise.
11646 ----------------------
11647 -- Within_HSS_Or_If --
11648 ----------------------
11650 function Within_HSS_Or_If (E : Entity_Id) return Boolean is
11653 N := Declaration_Node (E);
11660 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
11666 end Within_HSS_Or_If;
11668 -- Start of processing for Set_Public_Status
11671 -- Everything in the scope of Standard is public
11673 if S = Standard_Standard then
11674 Set_Is_Public (Id);
11676 -- Entity is definitely not public if enclosing scope is not public
11678 elsif not Is_Public (S) then
11681 -- An object or function declaration that occurs in a handled sequence
11682 -- of statements or within an if statement is the declaration for a
11683 -- temporary object or local subprogram generated by the expander. It
11684 -- never needs to be made public and furthermore, making it public can
11685 -- cause back end problems.
11687 elsif Nkind_In (Parent (Id), N_Object_Declaration,
11688 N_Function_Specification)
11689 and then Within_HSS_Or_If (Id)
11693 -- Entities in public packages or records are public
11695 elsif Ekind (S) = E_Package or Is_Record_Type (S) then
11696 Set_Is_Public (Id);
11698 -- The bounds of an entry family declaration can generate object
11699 -- declarations that are visible to the back-end, e.g. in the
11700 -- the declaration of a composite type that contains tasks.
11702 elsif Is_Concurrent_Type (S)
11703 and then not Has_Completion (S)
11704 and then Nkind (Parent (Id)) = N_Object_Declaration
11706 Set_Is_Public (Id);
11708 end Set_Public_Status;
11710 -----------------------------
11711 -- Set_Referenced_Modified --
11712 -----------------------------
11714 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
11718 -- Deal with indexed or selected component where prefix is modified
11720 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
11721 Pref := Prefix (N);
11723 -- If prefix is access type, then it is the designated object that is
11724 -- being modified, which means we have no entity to set the flag on.
11726 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
11729 -- Otherwise chase the prefix
11732 Set_Referenced_Modified (Pref, Out_Param);
11735 -- Otherwise see if we have an entity name (only other case to process)
11737 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
11738 Set_Referenced_As_LHS (Entity (N), not Out_Param);
11739 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
11741 end Set_Referenced_Modified;
11743 ----------------------------
11744 -- Set_Scope_Is_Transient --
11745 ----------------------------
11747 procedure Set_Scope_Is_Transient (V : Boolean := True) is
11749 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
11750 end Set_Scope_Is_Transient;
11752 -------------------
11753 -- Set_Size_Info --
11754 -------------------
11756 procedure Set_Size_Info (T1, T2 : Entity_Id) is
11758 -- We copy Esize, but not RM_Size, since in general RM_Size is
11759 -- subtype specific and does not get inherited by all subtypes.
11761 Set_Esize (T1, Esize (T2));
11762 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
11764 if Is_Discrete_Or_Fixed_Point_Type (T1)
11766 Is_Discrete_Or_Fixed_Point_Type (T2)
11768 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
11771 Set_Alignment (T1, Alignment (T2));
11774 --------------------
11775 -- Static_Boolean --
11776 --------------------
11778 function Static_Boolean (N : Node_Id) return Uint is
11780 Analyze_And_Resolve (N, Standard_Boolean);
11783 or else Error_Posted (N)
11784 or else Etype (N) = Any_Type
11789 if Is_Static_Expression (N) then
11790 if not Raises_Constraint_Error (N) then
11791 return Expr_Value (N);
11796 elsif Etype (N) = Any_Type then
11800 Flag_Non_Static_Expr
11801 ("static boolean expression required here", N);
11804 end Static_Boolean;
11806 --------------------
11807 -- Static_Integer --
11808 --------------------
11810 function Static_Integer (N : Node_Id) return Uint is
11812 Analyze_And_Resolve (N, Any_Integer);
11815 or else Error_Posted (N)
11816 or else Etype (N) = Any_Type
11821 if Is_Static_Expression (N) then
11822 if not Raises_Constraint_Error (N) then
11823 return Expr_Value (N);
11828 elsif Etype (N) = Any_Type then
11832 Flag_Non_Static_Expr
11833 ("static integer expression required here", N);
11836 end Static_Integer;
11838 --------------------------
11839 -- Statically_Different --
11840 --------------------------
11842 function Statically_Different (E1, E2 : Node_Id) return Boolean is
11843 R1 : constant Node_Id := Get_Referenced_Object (E1);
11844 R2 : constant Node_Id := Get_Referenced_Object (E2);
11846 return Is_Entity_Name (R1)
11847 and then Is_Entity_Name (R2)
11848 and then Entity (R1) /= Entity (R2)
11849 and then not Is_Formal (Entity (R1))
11850 and then not Is_Formal (Entity (R2));
11851 end Statically_Different;
11853 -----------------------------
11854 -- Subprogram_Access_Level --
11855 -----------------------------
11857 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
11859 if Present (Alias (Subp)) then
11860 return Subprogram_Access_Level (Alias (Subp));
11862 return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
11864 end Subprogram_Access_Level;
11870 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
11872 if Debug_Flag_W then
11873 for J in 0 .. Scope_Stack.Last loop
11878 Write_Name (Chars (E));
11879 Write_Str (" from ");
11880 Write_Location (Sloc (N));
11885 -----------------------
11886 -- Transfer_Entities --
11887 -----------------------
11889 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
11890 Ent : Entity_Id := First_Entity (From);
11897 if (Last_Entity (To)) = Empty then
11898 Set_First_Entity (To, Ent);
11900 Set_Next_Entity (Last_Entity (To), Ent);
11903 Set_Last_Entity (To, Last_Entity (From));
11905 while Present (Ent) loop
11906 Set_Scope (Ent, To);
11908 if not Is_Public (Ent) then
11909 Set_Public_Status (Ent);
11912 and then Ekind (Ent) = E_Record_Subtype
11915 -- The components of the propagated Itype must be public
11921 Comp := First_Entity (Ent);
11922 while Present (Comp) loop
11923 Set_Is_Public (Comp);
11924 Next_Entity (Comp);
11933 Set_First_Entity (From, Empty);
11934 Set_Last_Entity (From, Empty);
11935 end Transfer_Entities;
11937 -----------------------
11938 -- Type_Access_Level --
11939 -----------------------
11941 function Type_Access_Level (Typ : Entity_Id) return Uint is
11945 Btyp := Base_Type (Typ);
11947 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
11948 -- simply use the level where the type is declared. This is true for
11949 -- stand-alone object declarations, and for anonymous access types
11950 -- associated with components the level is the same as that of the
11951 -- enclosing composite type. However, special treatment is needed for
11952 -- the cases of access parameters, return objects of an anonymous access
11953 -- type, and, in Ada 95, access discriminants of limited types.
11955 if Ekind (Btyp) in Access_Kind then
11956 if Ekind (Btyp) = E_Anonymous_Access_Type then
11958 -- If the type is a nonlocal anonymous access type (such as for
11959 -- an access parameter) we treat it as being declared at the
11960 -- library level to ensure that names such as X.all'access don't
11961 -- fail static accessibility checks.
11963 if not Is_Local_Anonymous_Access (Typ) then
11964 return Scope_Depth (Standard_Standard);
11966 -- If this is a return object, the accessibility level is that of
11967 -- the result subtype of the enclosing function. The test here is
11968 -- little complicated, because we have to account for extended
11969 -- return statements that have been rewritten as blocks, in which
11970 -- case we have to find and the Is_Return_Object attribute of the
11971 -- itype's associated object. It would be nice to find a way to
11972 -- simplify this test, but it doesn't seem worthwhile to add a new
11973 -- flag just for purposes of this test. ???
11975 elsif Ekind (Scope (Btyp)) = E_Return_Statement
11978 and then Nkind (Associated_Node_For_Itype (Btyp)) =
11979 N_Object_Declaration
11980 and then Is_Return_Object
11981 (Defining_Identifier
11982 (Associated_Node_For_Itype (Btyp))))
11988 Scop := Scope (Scope (Btyp));
11989 while Present (Scop) loop
11990 exit when Ekind (Scop) = E_Function;
11991 Scop := Scope (Scop);
11994 -- Treat the return object's type as having the level of the
11995 -- function's result subtype (as per RM05-6.5(5.3/2)).
11997 return Type_Access_Level (Etype (Scop));
12002 Btyp := Root_Type (Btyp);
12004 -- The accessibility level of anonymous access types associated with
12005 -- discriminants is that of the current instance of the type, and
12006 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
12008 -- AI-402: access discriminants have accessibility based on the
12009 -- object rather than the type in Ada 2005, so the above paragraph
12012 -- ??? Needs completion with rules from AI-416
12014 if Ada_Version <= Ada_95
12015 and then Ekind (Typ) = E_Anonymous_Access_Type
12016 and then Present (Associated_Node_For_Itype (Typ))
12017 and then Nkind (Associated_Node_For_Itype (Typ)) =
12018 N_Discriminant_Specification
12020 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
12024 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
12025 end Type_Access_Level;
12027 --------------------------
12028 -- Unit_Declaration_Node --
12029 --------------------------
12031 function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
12032 N : Node_Id := Parent (Unit_Id);
12035 -- Predefined operators do not have a full function declaration
12037 if Ekind (Unit_Id) = E_Operator then
12041 -- Isn't there some better way to express the following ???
12043 while Nkind (N) /= N_Abstract_Subprogram_Declaration
12044 and then Nkind (N) /= N_Formal_Package_Declaration
12045 and then Nkind (N) /= N_Function_Instantiation
12046 and then Nkind (N) /= N_Generic_Package_Declaration
12047 and then Nkind (N) /= N_Generic_Subprogram_Declaration
12048 and then Nkind (N) /= N_Package_Declaration
12049 and then Nkind (N) /= N_Package_Body
12050 and then Nkind (N) /= N_Package_Instantiation
12051 and then Nkind (N) /= N_Package_Renaming_Declaration
12052 and then Nkind (N) /= N_Procedure_Instantiation
12053 and then Nkind (N) /= N_Protected_Body
12054 and then Nkind (N) /= N_Subprogram_Declaration
12055 and then Nkind (N) /= N_Subprogram_Body
12056 and then Nkind (N) /= N_Subprogram_Body_Stub
12057 and then Nkind (N) /= N_Subprogram_Renaming_Declaration
12058 and then Nkind (N) /= N_Task_Body
12059 and then Nkind (N) /= N_Task_Type_Declaration
12060 and then Nkind (N) not in N_Formal_Subprogram_Declaration
12061 and then Nkind (N) not in N_Generic_Renaming_Declaration
12064 pragma Assert (Present (N));
12068 end Unit_Declaration_Node;
12070 ---------------------
12071 -- Unit_Is_Visible --
12072 ---------------------
12074 function Unit_Is_Visible (U : Entity_Id) return Boolean is
12075 Curr : constant Node_Id := Cunit (Current_Sem_Unit);
12076 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
12078 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
12079 -- For a child unit, check whether unit appears in a with_clause
12082 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
12083 -- Scan the context clause of one compilation unit looking for a
12084 -- with_clause for the unit in question.
12086 ----------------------------
12087 -- Unit_In_Parent_Context --
12088 ----------------------------
12090 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
12092 if Unit_In_Context (Par_Unit) then
12095 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
12096 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
12101 end Unit_In_Parent_Context;
12103 ---------------------
12104 -- Unit_In_Context --
12105 ---------------------
12107 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
12111 Clause := First (Context_Items (Comp_Unit));
12112 while Present (Clause) loop
12113 if Nkind (Clause) = N_With_Clause then
12114 if Library_Unit (Clause) = U then
12117 -- The with_clause may denote a renaming of the unit we are
12118 -- looking for, eg. Text_IO which renames Ada.Text_IO.
12121 Renamed_Entity (Entity (Name (Clause))) =
12122 Defining_Entity (Unit (U))
12132 end Unit_In_Context;
12134 -- Start of processing for Unit_Is_Visible
12137 -- The currrent unit is directly visible.
12142 elsif Unit_In_Context (Curr) then
12145 -- If the current unit is a body, check the context of the spec.
12147 elsif Nkind (Unit (Curr)) = N_Package_Body
12149 (Nkind (Unit (Curr)) = N_Subprogram_Body
12150 and then not Acts_As_Spec (Unit (Curr)))
12152 if Unit_In_Context (Library_Unit (Curr)) then
12157 -- If the spec is a child unit, examine the parents.
12159 if Is_Child_Unit (Curr_Entity) then
12160 if Nkind (Unit (Curr)) in N_Unit_Body then
12162 Unit_In_Parent_Context
12163 (Parent_Spec (Unit (Library_Unit (Curr))));
12165 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
12171 end Unit_Is_Visible;
12173 ------------------------------
12174 -- Universal_Interpretation --
12175 ------------------------------
12177 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
12178 Index : Interp_Index;
12182 -- The argument may be a formal parameter of an operator or subprogram
12183 -- with multiple interpretations, or else an expression for an actual.
12185 if Nkind (Opnd) = N_Defining_Identifier
12186 or else not Is_Overloaded (Opnd)
12188 if Etype (Opnd) = Universal_Integer
12189 or else Etype (Opnd) = Universal_Real
12191 return Etype (Opnd);
12197 Get_First_Interp (Opnd, Index, It);
12198 while Present (It.Typ) loop
12199 if It.Typ = Universal_Integer
12200 or else It.Typ = Universal_Real
12205 Get_Next_Interp (Index, It);
12210 end Universal_Interpretation;
12216 function Unqualify (Expr : Node_Id) return Node_Id is
12218 -- Recurse to handle unlikely case of multiple levels of qualification
12220 if Nkind (Expr) = N_Qualified_Expression then
12221 return Unqualify (Expression (Expr));
12223 -- Normal case, not a qualified expression
12230 -----------------------
12231 -- Visible_Ancestors --
12232 -----------------------
12234 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
12240 pragma Assert (Is_Record_Type (Typ)
12241 and then Is_Tagged_Type (Typ));
12243 -- Collect all the parents and progenitors of Typ. If the full-view of
12244 -- private parents and progenitors is available then it is used to
12245 -- generate the list of visible ancestors; otherwise their partial
12246 -- view is added to the resulting list.
12251 Use_Full_View => True);
12255 Ifaces_List => List_2,
12256 Exclude_Parents => True,
12257 Use_Full_View => True);
12259 -- Join the two lists. Avoid duplications because an interface may
12260 -- simultaneously be parent and progenitor of a type.
12262 Elmt := First_Elmt (List_2);
12263 while Present (Elmt) loop
12264 Append_Unique_Elmt (Node (Elmt), List_1);
12269 end Visible_Ancestors;
12271 ----------------------
12272 -- Within_Init_Proc --
12273 ----------------------
12275 function Within_Init_Proc return Boolean is
12279 S := Current_Scope;
12280 while not Is_Overloadable (S) loop
12281 if S = Standard_Standard then
12288 return Is_Init_Proc (S);
12289 end Within_Init_Proc;
12295 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
12296 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
12297 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
12299 function Has_One_Matching_Field return Boolean;
12300 -- Determines if Expec_Type is a record type with a single component or
12301 -- discriminant whose type matches the found type or is one dimensional
12302 -- array whose component type matches the found type.
12304 ----------------------------
12305 -- Has_One_Matching_Field --
12306 ----------------------------
12308 function Has_One_Matching_Field return Boolean is
12312 if Is_Array_Type (Expec_Type)
12313 and then Number_Dimensions (Expec_Type) = 1
12315 Covers (Etype (Component_Type (Expec_Type)), Found_Type)
12319 elsif not Is_Record_Type (Expec_Type) then
12323 E := First_Entity (Expec_Type);
12328 elsif (Ekind (E) /= E_Discriminant
12329 and then Ekind (E) /= E_Component)
12330 or else (Chars (E) = Name_uTag
12331 or else Chars (E) = Name_uParent)
12340 if not Covers (Etype (E), Found_Type) then
12343 elsif Present (Next_Entity (E)) then
12350 end Has_One_Matching_Field;
12352 -- Start of processing for Wrong_Type
12355 -- Don't output message if either type is Any_Type, or if a message
12356 -- has already been posted for this node. We need to do the latter
12357 -- check explicitly (it is ordinarily done in Errout), because we
12358 -- are using ! to force the output of the error messages.
12360 if Expec_Type = Any_Type
12361 or else Found_Type = Any_Type
12362 or else Error_Posted (Expr)
12366 -- In an instance, there is an ongoing problem with completion of
12367 -- type derived from private types. Their structure is what Gigi
12368 -- expects, but the Etype is the parent type rather than the
12369 -- derived private type itself. Do not flag error in this case. The
12370 -- private completion is an entity without a parent, like an Itype.
12371 -- Similarly, full and partial views may be incorrect in the instance.
12372 -- There is no simple way to insure that it is consistent ???
12374 elsif In_Instance then
12375 if Etype (Etype (Expr)) = Etype (Expected_Type)
12377 (Has_Private_Declaration (Expected_Type)
12378 or else Has_Private_Declaration (Etype (Expr)))
12379 and then No (Parent (Expected_Type))
12385 -- An interesting special check. If the expression is parenthesized
12386 -- and its type corresponds to the type of the sole component of the
12387 -- expected record type, or to the component type of the expected one
12388 -- dimensional array type, then assume we have a bad aggregate attempt.
12390 if Nkind (Expr) in N_Subexpr
12391 and then Paren_Count (Expr) /= 0
12392 and then Has_One_Matching_Field
12394 Error_Msg_N ("positional aggregate cannot have one component", Expr);
12396 -- Another special check, if we are looking for a pool-specific access
12397 -- type and we found an E_Access_Attribute_Type, then we have the case
12398 -- of an Access attribute being used in a context which needs a pool-
12399 -- specific type, which is never allowed. The one extra check we make
12400 -- is that the expected designated type covers the Found_Type.
12402 elsif Is_Access_Type (Expec_Type)
12403 and then Ekind (Found_Type) = E_Access_Attribute_Type
12404 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
12405 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
12407 (Designated_Type (Expec_Type), Designated_Type (Found_Type))
12409 Error_Msg_N -- CODEFIX
12410 ("result must be general access type!", Expr);
12411 Error_Msg_NE -- CODEFIX
12412 ("add ALL to }!", Expr, Expec_Type);
12414 -- Another special check, if the expected type is an integer type,
12415 -- but the expression is of type System.Address, and the parent is
12416 -- an addition or subtraction operation whose left operand is the
12417 -- expression in question and whose right operand is of an integral
12418 -- type, then this is an attempt at address arithmetic, so give
12419 -- appropriate message.
12421 elsif Is_Integer_Type (Expec_Type)
12422 and then Is_RTE (Found_Type, RE_Address)
12423 and then (Nkind (Parent (Expr)) = N_Op_Add
12425 Nkind (Parent (Expr)) = N_Op_Subtract)
12426 and then Expr = Left_Opnd (Parent (Expr))
12427 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
12430 ("address arithmetic not predefined in package System",
12433 ("\possible missing with/use of System.Storage_Elements",
12437 -- If the expected type is an anonymous access type, as for access
12438 -- parameters and discriminants, the error is on the designated types.
12440 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
12441 if Comes_From_Source (Expec_Type) then
12442 Error_Msg_NE ("expected}!", Expr, Expec_Type);
12445 ("expected an access type with designated}",
12446 Expr, Designated_Type (Expec_Type));
12449 if Is_Access_Type (Found_Type)
12450 and then not Comes_From_Source (Found_Type)
12453 ("\\found an access type with designated}!",
12454 Expr, Designated_Type (Found_Type));
12456 if From_With_Type (Found_Type) then
12457 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
12458 Error_Msg_Qual_Level := 99;
12459 Error_Msg_NE -- CODEFIX
12460 ("\\missing `WITH &;", Expr, Scope (Found_Type));
12461 Error_Msg_Qual_Level := 0;
12463 Error_Msg_NE ("found}!", Expr, Found_Type);
12467 -- Normal case of one type found, some other type expected
12470 -- If the names of the two types are the same, see if some number
12471 -- of levels of qualification will help. Don't try more than three
12472 -- levels, and if we get to standard, it's no use (and probably
12473 -- represents an error in the compiler) Also do not bother with
12474 -- internal scope names.
12477 Expec_Scope : Entity_Id;
12478 Found_Scope : Entity_Id;
12481 Expec_Scope := Expec_Type;
12482 Found_Scope := Found_Type;
12484 for Levels in Int range 0 .. 3 loop
12485 if Chars (Expec_Scope) /= Chars (Found_Scope) then
12486 Error_Msg_Qual_Level := Levels;
12490 Expec_Scope := Scope (Expec_Scope);
12491 Found_Scope := Scope (Found_Scope);
12493 exit when Expec_Scope = Standard_Standard
12494 or else Found_Scope = Standard_Standard
12495 or else not Comes_From_Source (Expec_Scope)
12496 or else not Comes_From_Source (Found_Scope);
12500 if Is_Record_Type (Expec_Type)
12501 and then Present (Corresponding_Remote_Type (Expec_Type))
12503 Error_Msg_NE ("expected}!", Expr,
12504 Corresponding_Remote_Type (Expec_Type));
12506 Error_Msg_NE ("expected}!", Expr, Expec_Type);
12509 if Is_Entity_Name (Expr)
12510 and then Is_Package_Or_Generic_Package (Entity (Expr))
12512 Error_Msg_N ("\\found package name!", Expr);
12514 elsif Is_Entity_Name (Expr)
12516 (Ekind (Entity (Expr)) = E_Procedure
12518 Ekind (Entity (Expr)) = E_Generic_Procedure)
12520 if Ekind (Expec_Type) = E_Access_Subprogram_Type then
12522 ("found procedure name, possibly missing Access attribute!",
12526 ("\\found procedure name instead of function!", Expr);
12529 elsif Nkind (Expr) = N_Function_Call
12530 and then Ekind (Expec_Type) = E_Access_Subprogram_Type
12531 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
12532 and then No (Parameter_Associations (Expr))
12535 ("found function name, possibly missing Access attribute!",
12538 -- Catch common error: a prefix or infix operator which is not
12539 -- directly visible because the type isn't.
12541 elsif Nkind (Expr) in N_Op
12542 and then Is_Overloaded (Expr)
12543 and then not Is_Immediately_Visible (Expec_Type)
12544 and then not Is_Potentially_Use_Visible (Expec_Type)
12545 and then not In_Use (Expec_Type)
12546 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
12549 ("operator of the type is not directly visible!", Expr);
12551 elsif Ekind (Found_Type) = E_Void
12552 and then Present (Parent (Found_Type))
12553 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
12555 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
12558 Error_Msg_NE ("\\found}!", Expr, Found_Type);
12561 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
12562 -- of the same modular type, and (M1 and M2) = 0 was intended.
12564 if Expec_Type = Standard_Boolean
12565 and then Is_Modular_Integer_Type (Found_Type)
12566 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
12567 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
12570 Op : constant Node_Id := Right_Opnd (Parent (Expr));
12571 L : constant Node_Id := Left_Opnd (Op);
12572 R : constant Node_Id := Right_Opnd (Op);
12574 -- The case for the message is when the left operand of the
12575 -- comparison is the same modular type, or when it is an
12576 -- integer literal (or other universal integer expression),
12577 -- which would have been typed as the modular type if the
12578 -- parens had been there.
12580 if (Etype (L) = Found_Type
12582 Etype (L) = Universal_Integer)
12583 and then Is_Integer_Type (Etype (R))
12586 ("\\possible missing parens for modular operation", Expr);
12591 -- Reset error message qualification indication
12593 Error_Msg_Qual_Level := 0;