PR target/58115
[official-gcc.git] / gcc / ada / sem_util.adb
blob08acd702caf32e67903a54f971c4185ed6f7fa26
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ U T I L --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Casing; use Casing;
28 with Checks; use Checks;
29 with Debug; use Debug;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Exp_Ch11; use Exp_Ch11;
33 with Exp_Disp; use Exp_Disp;
34 with Exp_Util; use Exp_Util;
35 with Fname; use Fname;
36 with Freeze; use Freeze;
37 with Lib; use Lib;
38 with Lib.Xref; use Lib.Xref;
39 with Namet.Sp; use Namet.Sp;
40 with Nlists; use Nlists;
41 with Nmake; use Nmake;
42 with Output; use Output;
43 with Opt; use Opt;
44 with Restrict; use Restrict;
45 with Rident; use Rident;
46 with Rtsfind; use Rtsfind;
47 with Sem; use Sem;
48 with Sem_Aux; use Sem_Aux;
49 with Sem_Attr; use Sem_Attr;
50 with Sem_Ch8; use Sem_Ch8;
51 with Sem_Disp; use Sem_Disp;
52 with Sem_Eval; use Sem_Eval;
53 with Sem_Res; use Sem_Res;
54 with Sem_Type; use Sem_Type;
55 with Sinfo; use Sinfo;
56 with Sinput; use Sinput;
57 with Stand; use Stand;
58 with Style;
59 with Stringt; use Stringt;
60 with Targparm; use Targparm;
61 with Tbuild; use Tbuild;
62 with Ttypes; use Ttypes;
63 with Uname; use Uname;
65 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 := 0;
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 -- Local Subprograms --
100 -----------------------
102 function Build_Component_Subtype
103 (C : List_Id;
104 Loc : Source_Ptr;
105 T : Entity_Id) return Node_Id;
106 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
107 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
108 -- Loc is the source location, T is the original subtype.
110 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
111 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
112 -- with discriminants whose default values are static, examine only the
113 -- components in the selected variant to determine whether all of them
114 -- have a default.
116 function Has_Null_Extension (T : Entity_Id) return Boolean;
117 -- T is a derived tagged type. Check whether the type extension is null.
118 -- If the parent type is fully initialized, T can be treated as such.
120 ------------------------------
121 -- Abstract_Interface_List --
122 ------------------------------
124 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
125 Nod : Node_Id;
127 begin
128 if Is_Concurrent_Type (Typ) then
130 -- If we are dealing with a synchronized subtype, go to the base
131 -- type, whose declaration has the interface list.
133 -- Shouldn't this be Declaration_Node???
135 Nod := Parent (Base_Type (Typ));
137 if Nkind (Nod) = N_Full_Type_Declaration then
138 return Empty_List;
139 end if;
141 elsif Ekind (Typ) = E_Record_Type_With_Private then
142 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
143 Nod := Type_Definition (Parent (Typ));
145 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
146 if Present (Full_View (Typ))
147 and then Nkind (Parent (Full_View (Typ)))
148 = N_Full_Type_Declaration
149 then
150 Nod := Type_Definition (Parent (Full_View (Typ)));
152 -- If the full-view is not available we cannot do anything else
153 -- here (the source has errors).
155 else
156 return Empty_List;
157 end if;
159 -- Support for generic formals with interfaces is still missing ???
161 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
162 return Empty_List;
164 else
165 pragma Assert
166 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
167 Nod := Parent (Typ);
168 end if;
170 elsif Ekind (Typ) = E_Record_Subtype then
171 Nod := Type_Definition (Parent (Etype (Typ)));
173 elsif Ekind (Typ) = E_Record_Subtype_With_Private then
175 -- Recurse, because parent may still be a private extension. Also
176 -- note that the full view of the subtype or the full view of its
177 -- base type may (both) be unavailable.
179 return Abstract_Interface_List (Etype (Typ));
181 else pragma Assert ((Ekind (Typ)) = E_Record_Type);
182 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
183 Nod := Formal_Type_Definition (Parent (Typ));
184 else
185 Nod := Type_Definition (Parent (Typ));
186 end if;
187 end if;
189 return Interface_List (Nod);
190 end Abstract_Interface_List;
192 --------------------------------
193 -- Add_Access_Type_To_Process --
194 --------------------------------
196 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
197 L : Elist_Id;
199 begin
200 Ensure_Freeze_Node (E);
201 L := Access_Types_To_Process (Freeze_Node (E));
203 if No (L) then
204 L := New_Elmt_List;
205 Set_Access_Types_To_Process (Freeze_Node (E), L);
206 end if;
208 Append_Elmt (A, L);
209 end Add_Access_Type_To_Process;
211 -----------------------
212 -- Add_Contract_Item --
213 -----------------------
215 procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id) is
216 Items : constant Node_Id := Contract (Id);
217 Nam : Name_Id;
218 N : Node_Id;
220 begin
221 -- The related context must have a contract and the item to be added
222 -- must be a pragma.
224 pragma Assert (Present (Items));
225 pragma Assert (Nkind (Prag) = N_Pragma);
227 Nam := Original_Aspect_Name (Prag);
229 -- Contract items related to [generic] packages. The applicable pragmas
230 -- are:
231 -- Abstract_States
232 -- Initial_Condition
233 -- Initializes
235 if Ekind_In (Id, E_Generic_Package, E_Package) then
236 if Nam_In (Nam, Name_Abstract_State,
237 Name_Initial_Condition,
238 Name_Initializes)
239 then
240 Set_Next_Pragma (Prag, Classifications (Items));
241 Set_Classifications (Items, Prag);
243 -- The pragma is not a proper contract item
245 else
246 raise Program_Error;
247 end if;
249 -- Contract items related to package bodies. The applicable pragmas are:
250 -- Refined_States
252 elsif Ekind (Id) = E_Package_Body then
253 if Nam = Name_Refined_State then
254 Set_Next_Pragma (Prag, Classifications (Items));
255 Set_Classifications (Items, Prag);
257 -- The pragma is not a proper contract item
259 else
260 raise Program_Error;
261 end if;
263 -- Contract items related to subprogram or entry declarations. The
264 -- applicable pragmas are:
265 -- Contract_Cases
266 -- Depends
267 -- Global
268 -- Post
269 -- Postcondition
270 -- Pre
271 -- Precondition
272 -- Test_Case
274 elsif Ekind_In (Id, E_Entry, E_Entry_Family)
275 or else Is_Generic_Subprogram (Id)
276 or else Is_Subprogram (Id)
277 then
278 if Nam_In (Nam, Name_Precondition,
279 Name_Postcondition,
280 Name_Pre,
281 Name_Post,
282 Name_uPre,
283 Name_uPost)
284 then
285 -- Before we add a precondition or postcondition to the list,
286 -- make sure we do not have a disallowed duplicate, which can
287 -- happen if we use a pragma for Pre[_Class] or Post[_Class]
288 -- instead of the corresponding aspect.
290 if not From_Aspect_Specification (Prag)
291 and then Nam_In (Nam, Name_Pre_Class,
292 Name_Pre,
293 Name_uPre,
294 Name_Post_Class,
295 Name_Post,
296 Name_uPost)
297 then
298 N := Pre_Post_Conditions (Items);
299 while Present (N) loop
300 if not Split_PPC (N)
301 and then Original_Aspect_Name (N) = Nam
302 then
303 Error_Msg_Sloc := Sloc (N);
304 Error_Msg_NE
305 ("duplication of aspect for & given#", Prag, Id);
306 return;
307 else
308 N := Next_Pragma (N);
309 end if;
310 end loop;
311 end if;
313 Set_Next_Pragma (Prag, Pre_Post_Conditions (Items));
314 Set_Pre_Post_Conditions (Items, Prag);
316 elsif Nam_In (Nam, Name_Contract_Cases, Name_Test_Case) then
317 Set_Next_Pragma (Prag, Contract_Test_Cases (Items));
318 Set_Contract_Test_Cases (Items, Prag);
320 elsif Nam_In (Nam, Name_Depends, Name_Global) then
321 Set_Next_Pragma (Prag, Classifications (Items));
322 Set_Classifications (Items, Prag);
324 -- The pragma is not a proper contract item
326 else
327 raise Program_Error;
328 end if;
330 -- Contract items related to subprogram bodies. The applicable pragmas
331 -- are:
332 -- Refined_Depends
333 -- Refined_Global
335 elsif Ekind (Id) = E_Subprogram_Body then
336 if Nam_In (Nam, Name_Refined_Depends, Name_Refined_Global) then
337 Set_Next_Pragma (Prag, Classifications (Items));
338 Set_Classifications (Items, Prag);
340 -- The pragma is not a proper contract item
342 else
343 raise Program_Error;
344 end if;
345 end if;
346 end Add_Contract_Item;
348 ----------------------------
349 -- Add_Global_Declaration --
350 ----------------------------
352 procedure Add_Global_Declaration (N : Node_Id) is
353 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
355 begin
356 if No (Declarations (Aux_Node)) then
357 Set_Declarations (Aux_Node, New_List);
358 end if;
360 Append_To (Declarations (Aux_Node), N);
361 Analyze (N);
362 end Add_Global_Declaration;
364 -----------------
365 -- Addressable --
366 -----------------
368 -- For now, just 8/16/32/64. but analyze later if AAMP is special???
370 function Addressable (V : Uint) return Boolean is
371 begin
372 return V = Uint_8 or else
373 V = Uint_16 or else
374 V = Uint_32 or else
375 V = Uint_64;
376 end Addressable;
378 function Addressable (V : Int) return Boolean is
379 begin
380 return V = 8 or else
381 V = 16 or else
382 V = 32 or else
383 V = 64;
384 end Addressable;
386 -----------------------
387 -- Alignment_In_Bits --
388 -----------------------
390 function Alignment_In_Bits (E : Entity_Id) return Uint is
391 begin
392 return Alignment (E) * System_Storage_Unit;
393 end Alignment_In_Bits;
395 ---------------------------------
396 -- Append_Inherited_Subprogram --
397 ---------------------------------
399 procedure Append_Inherited_Subprogram (S : Entity_Id) is
400 Par : constant Entity_Id := Alias (S);
401 -- The parent subprogram
403 Scop : constant Entity_Id := Scope (Par);
404 -- The scope of definition of the parent subprogram
406 Typ : constant Entity_Id := Defining_Entity (Parent (S));
407 -- The derived type of which S is a primitive operation
409 Decl : Node_Id;
410 Next_E : Entity_Id;
412 begin
413 if Ekind (Current_Scope) = E_Package
414 and then In_Private_Part (Current_Scope)
415 and then Has_Private_Declaration (Typ)
416 and then Is_Tagged_Type (Typ)
417 and then Scop = Current_Scope
418 then
419 -- The inherited operation is available at the earliest place after
420 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only
421 -- relevant for type extensions. If the parent operation appears
422 -- after the type extension, the operation is not visible.
424 Decl := First
425 (Visible_Declarations
426 (Package_Specification (Current_Scope)));
427 while Present (Decl) loop
428 if Nkind (Decl) = N_Private_Extension_Declaration
429 and then Defining_Entity (Decl) = Typ
430 then
431 if Sloc (Decl) > Sloc (Par) then
432 Next_E := Next_Entity (Par);
433 Set_Next_Entity (Par, S);
434 Set_Next_Entity (S, Next_E);
435 return;
437 else
438 exit;
439 end if;
440 end if;
442 Next (Decl);
443 end loop;
444 end if;
446 -- If partial view is not a type extension, or it appears before the
447 -- subprogram declaration, insert normally at end of entity list.
449 Append_Entity (S, Current_Scope);
450 end Append_Inherited_Subprogram;
452 -----------------------------------------
453 -- Apply_Compile_Time_Constraint_Error --
454 -----------------------------------------
456 procedure Apply_Compile_Time_Constraint_Error
457 (N : Node_Id;
458 Msg : String;
459 Reason : RT_Exception_Code;
460 Ent : Entity_Id := Empty;
461 Typ : Entity_Id := Empty;
462 Loc : Source_Ptr := No_Location;
463 Rep : Boolean := True;
464 Warn : Boolean := False)
466 Stat : constant Boolean := Is_Static_Expression (N);
467 R_Stat : constant Node_Id :=
468 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
469 Rtyp : Entity_Id;
471 begin
472 if No (Typ) then
473 Rtyp := Etype (N);
474 else
475 Rtyp := Typ;
476 end if;
478 Discard_Node
479 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
481 if not Rep then
482 return;
483 end if;
485 -- Now we replace the node by an N_Raise_Constraint_Error node
486 -- This does not need reanalyzing, so set it as analyzed now.
488 Rewrite (N, R_Stat);
489 Set_Analyzed (N, True);
491 Set_Etype (N, Rtyp);
492 Set_Raises_Constraint_Error (N);
494 -- Now deal with possible local raise handling
496 Possible_Local_Raise (N, Standard_Constraint_Error);
498 -- If the original expression was marked as static, the result is
499 -- still marked as static, but the Raises_Constraint_Error flag is
500 -- always set so that further static evaluation is not attempted.
502 if Stat then
503 Set_Is_Static_Expression (N);
504 end if;
505 end Apply_Compile_Time_Constraint_Error;
507 --------------------------------------
508 -- Available_Full_View_Of_Component --
509 --------------------------------------
511 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
512 ST : constant Entity_Id := Scope (T);
513 SCT : constant Entity_Id := Scope (Component_Type (T));
514 begin
515 return In_Open_Scopes (ST)
516 and then In_Open_Scopes (SCT)
517 and then Scope_Depth (ST) >= Scope_Depth (SCT);
518 end Available_Full_View_Of_Component;
520 -------------------
521 -- Bad_Attribute --
522 -------------------
524 procedure Bad_Attribute
525 (N : Node_Id;
526 Nam : Name_Id;
527 Warn : Boolean := False)
529 begin
530 Error_Msg_Warn := Warn;
531 Error_Msg_N ("unrecognized attribute&<", N);
533 -- Check for possible misspelling
535 Error_Msg_Name_1 := First_Attribute_Name;
536 while Error_Msg_Name_1 <= Last_Attribute_Name loop
537 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
538 Error_Msg_N -- CODEFIX
539 ("\possible misspelling of %<", N);
540 exit;
541 end if;
543 Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
544 end loop;
545 end Bad_Attribute;
547 --------------------------------
548 -- Bad_Predicated_Subtype_Use --
549 --------------------------------
551 procedure Bad_Predicated_Subtype_Use
552 (Msg : String;
553 N : Node_Id;
554 Typ : Entity_Id;
555 Suggest_Static : Boolean := False)
557 begin
558 if Has_Predicates (Typ) then
559 if Is_Generic_Actual_Type (Typ) then
560 Error_Msg_FE (Msg & "??", N, Typ);
561 Error_Msg_F ("\Program_Error will be raised at run time??", N);
562 Insert_Action (N,
563 Make_Raise_Program_Error (Sloc (N),
564 Reason => PE_Bad_Predicated_Generic_Type));
566 else
567 Error_Msg_FE (Msg, N, Typ);
568 end if;
570 -- Emit an optional suggestion on how to remedy the error if the
571 -- context warrants it.
573 if Suggest_Static and then Present (Static_Predicate (Typ)) then
574 Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
575 end if;
576 end if;
577 end Bad_Predicated_Subtype_Use;
579 --------------------------
580 -- Build_Actual_Subtype --
581 --------------------------
583 function Build_Actual_Subtype
584 (T : Entity_Id;
585 N : Node_Or_Entity_Id) return Node_Id
587 Loc : Source_Ptr;
588 -- Normally Sloc (N), but may point to corresponding body in some cases
590 Constraints : List_Id;
591 Decl : Node_Id;
592 Discr : Entity_Id;
593 Hi : Node_Id;
594 Lo : Node_Id;
595 Subt : Entity_Id;
596 Disc_Type : Entity_Id;
597 Obj : Node_Id;
599 begin
600 Loc := Sloc (N);
602 if Nkind (N) = N_Defining_Identifier then
603 Obj := New_Reference_To (N, Loc);
605 -- If this is a formal parameter of a subprogram declaration, and
606 -- we are compiling the body, we want the declaration for the
607 -- actual subtype to carry the source position of the body, to
608 -- prevent anomalies in gdb when stepping through the code.
610 if Is_Formal (N) then
611 declare
612 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
613 begin
614 if Nkind (Decl) = N_Subprogram_Declaration
615 and then Present (Corresponding_Body (Decl))
616 then
617 Loc := Sloc (Corresponding_Body (Decl));
618 end if;
619 end;
620 end if;
622 else
623 Obj := N;
624 end if;
626 if Is_Array_Type (T) then
627 Constraints := New_List;
628 for J in 1 .. Number_Dimensions (T) loop
630 -- Build an array subtype declaration with the nominal subtype and
631 -- the bounds of the actual. Add the declaration in front of the
632 -- local declarations for the subprogram, for analysis before any
633 -- reference to the formal in the body.
635 Lo :=
636 Make_Attribute_Reference (Loc,
637 Prefix =>
638 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
639 Attribute_Name => Name_First,
640 Expressions => New_List (
641 Make_Integer_Literal (Loc, J)));
643 Hi :=
644 Make_Attribute_Reference (Loc,
645 Prefix =>
646 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
647 Attribute_Name => Name_Last,
648 Expressions => New_List (
649 Make_Integer_Literal (Loc, J)));
651 Append (Make_Range (Loc, Lo, Hi), Constraints);
652 end loop;
654 -- If the type has unknown discriminants there is no constrained
655 -- subtype to build. This is never called for a formal or for a
656 -- lhs, so returning the type is ok ???
658 elsif Has_Unknown_Discriminants (T) then
659 return T;
661 else
662 Constraints := New_List;
664 -- Type T is a generic derived type, inherit the discriminants from
665 -- the parent type.
667 if Is_Private_Type (T)
668 and then No (Full_View (T))
670 -- T was flagged as an error if it was declared as a formal
671 -- derived type with known discriminants. In this case there
672 -- is no need to look at the parent type since T already carries
673 -- its own discriminants.
675 and then not Error_Posted (T)
676 then
677 Disc_Type := Etype (Base_Type (T));
678 else
679 Disc_Type := T;
680 end if;
682 Discr := First_Discriminant (Disc_Type);
683 while Present (Discr) loop
684 Append_To (Constraints,
685 Make_Selected_Component (Loc,
686 Prefix =>
687 Duplicate_Subexpr_No_Checks (Obj),
688 Selector_Name => New_Occurrence_Of (Discr, Loc)));
689 Next_Discriminant (Discr);
690 end loop;
691 end if;
693 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
694 Set_Is_Internal (Subt);
696 Decl :=
697 Make_Subtype_Declaration (Loc,
698 Defining_Identifier => Subt,
699 Subtype_Indication =>
700 Make_Subtype_Indication (Loc,
701 Subtype_Mark => New_Reference_To (T, Loc),
702 Constraint =>
703 Make_Index_Or_Discriminant_Constraint (Loc,
704 Constraints => Constraints)));
706 Mark_Rewrite_Insertion (Decl);
707 return Decl;
708 end Build_Actual_Subtype;
710 ---------------------------------------
711 -- Build_Actual_Subtype_Of_Component --
712 ---------------------------------------
714 function Build_Actual_Subtype_Of_Component
715 (T : Entity_Id;
716 N : Node_Id) return Node_Id
718 Loc : constant Source_Ptr := Sloc (N);
719 P : constant Node_Id := Prefix (N);
720 D : Elmt_Id;
721 Id : Node_Id;
722 Index_Typ : Entity_Id;
724 Desig_Typ : Entity_Id;
725 -- This is either a copy of T, or if T is an access type, then it is
726 -- the directly designated type of this access type.
728 function Build_Actual_Array_Constraint return List_Id;
729 -- If one or more of the bounds of the component depends on
730 -- discriminants, build actual constraint using the discriminants
731 -- of the prefix.
733 function Build_Actual_Record_Constraint return List_Id;
734 -- Similar to previous one, for discriminated components constrained
735 -- by the discriminant of the enclosing object.
737 -----------------------------------
738 -- Build_Actual_Array_Constraint --
739 -----------------------------------
741 function Build_Actual_Array_Constraint return List_Id is
742 Constraints : constant List_Id := New_List;
743 Indx : Node_Id;
744 Hi : Node_Id;
745 Lo : Node_Id;
746 Old_Hi : Node_Id;
747 Old_Lo : Node_Id;
749 begin
750 Indx := First_Index (Desig_Typ);
751 while Present (Indx) loop
752 Old_Lo := Type_Low_Bound (Etype (Indx));
753 Old_Hi := Type_High_Bound (Etype (Indx));
755 if Denotes_Discriminant (Old_Lo) then
756 Lo :=
757 Make_Selected_Component (Loc,
758 Prefix => New_Copy_Tree (P),
759 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
761 else
762 Lo := New_Copy_Tree (Old_Lo);
764 -- The new bound will be reanalyzed in the enclosing
765 -- declaration. For literal bounds that come from a type
766 -- declaration, the type of the context must be imposed, so
767 -- insure that analysis will take place. For non-universal
768 -- types this is not strictly necessary.
770 Set_Analyzed (Lo, False);
771 end if;
773 if Denotes_Discriminant (Old_Hi) then
774 Hi :=
775 Make_Selected_Component (Loc,
776 Prefix => New_Copy_Tree (P),
777 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
779 else
780 Hi := New_Copy_Tree (Old_Hi);
781 Set_Analyzed (Hi, False);
782 end if;
784 Append (Make_Range (Loc, Lo, Hi), Constraints);
785 Next_Index (Indx);
786 end loop;
788 return Constraints;
789 end Build_Actual_Array_Constraint;
791 ------------------------------------
792 -- Build_Actual_Record_Constraint --
793 ------------------------------------
795 function Build_Actual_Record_Constraint return List_Id is
796 Constraints : constant List_Id := New_List;
797 D : Elmt_Id;
798 D_Val : Node_Id;
800 begin
801 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
802 while Present (D) loop
803 if Denotes_Discriminant (Node (D)) then
804 D_Val := Make_Selected_Component (Loc,
805 Prefix => New_Copy_Tree (P),
806 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
808 else
809 D_Val := New_Copy_Tree (Node (D));
810 end if;
812 Append (D_Val, Constraints);
813 Next_Elmt (D);
814 end loop;
816 return Constraints;
817 end Build_Actual_Record_Constraint;
819 -- Start of processing for Build_Actual_Subtype_Of_Component
821 begin
822 -- Why the test for Spec_Expression mode here???
824 if In_Spec_Expression then
825 return Empty;
827 -- More comments for the rest of this body would be good ???
829 elsif Nkind (N) = N_Explicit_Dereference then
830 if Is_Composite_Type (T)
831 and then not Is_Constrained (T)
832 and then not (Is_Class_Wide_Type (T)
833 and then Is_Constrained (Root_Type (T)))
834 and then not Has_Unknown_Discriminants (T)
835 then
836 -- If the type of the dereference is already constrained, it is an
837 -- actual subtype.
839 if Is_Array_Type (Etype (N))
840 and then Is_Constrained (Etype (N))
841 then
842 return Empty;
843 else
844 Remove_Side_Effects (P);
845 return Build_Actual_Subtype (T, N);
846 end if;
847 else
848 return Empty;
849 end if;
850 end if;
852 if Ekind (T) = E_Access_Subtype then
853 Desig_Typ := Designated_Type (T);
854 else
855 Desig_Typ := T;
856 end if;
858 if Ekind (Desig_Typ) = E_Array_Subtype then
859 Id := First_Index (Desig_Typ);
860 while Present (Id) loop
861 Index_Typ := Underlying_Type (Etype (Id));
863 if Denotes_Discriminant (Type_Low_Bound (Index_Typ))
864 or else
865 Denotes_Discriminant (Type_High_Bound (Index_Typ))
866 then
867 Remove_Side_Effects (P);
868 return
869 Build_Component_Subtype
870 (Build_Actual_Array_Constraint, Loc, Base_Type (T));
871 end if;
873 Next_Index (Id);
874 end loop;
876 elsif Is_Composite_Type (Desig_Typ)
877 and then Has_Discriminants (Desig_Typ)
878 and then not Has_Unknown_Discriminants (Desig_Typ)
879 then
880 if Is_Private_Type (Desig_Typ)
881 and then No (Discriminant_Constraint (Desig_Typ))
882 then
883 Desig_Typ := Full_View (Desig_Typ);
884 end if;
886 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
887 while Present (D) loop
888 if Denotes_Discriminant (Node (D)) then
889 Remove_Side_Effects (P);
890 return
891 Build_Component_Subtype (
892 Build_Actual_Record_Constraint, Loc, Base_Type (T));
893 end if;
895 Next_Elmt (D);
896 end loop;
897 end if;
899 -- If none of the above, the actual and nominal subtypes are the same
901 return Empty;
902 end Build_Actual_Subtype_Of_Component;
904 -----------------------------
905 -- Build_Component_Subtype --
906 -----------------------------
908 function Build_Component_Subtype
909 (C : List_Id;
910 Loc : Source_Ptr;
911 T : Entity_Id) return Node_Id
913 Subt : Entity_Id;
914 Decl : Node_Id;
916 begin
917 -- Unchecked_Union components do not require component subtypes
919 if Is_Unchecked_Union (T) then
920 return Empty;
921 end if;
923 Subt := Make_Temporary (Loc, 'S');
924 Set_Is_Internal (Subt);
926 Decl :=
927 Make_Subtype_Declaration (Loc,
928 Defining_Identifier => Subt,
929 Subtype_Indication =>
930 Make_Subtype_Indication (Loc,
931 Subtype_Mark => New_Reference_To (Base_Type (T), Loc),
932 Constraint =>
933 Make_Index_Or_Discriminant_Constraint (Loc,
934 Constraints => C)));
936 Mark_Rewrite_Insertion (Decl);
937 return Decl;
938 end Build_Component_Subtype;
940 ---------------------------
941 -- Build_Default_Subtype --
942 ---------------------------
944 function Build_Default_Subtype
945 (T : Entity_Id;
946 N : Node_Id) return Entity_Id
948 Loc : constant Source_Ptr := Sloc (N);
949 Disc : Entity_Id;
951 Bas : Entity_Id;
952 -- The base type that is to be constrained by the defaults
954 begin
955 if not Has_Discriminants (T) or else Is_Constrained (T) then
956 return T;
957 end if;
959 Bas := Base_Type (T);
961 -- If T is non-private but its base type is private, this is the
962 -- completion of a subtype declaration whose parent type is private
963 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
964 -- are to be found in the full view of the base.
966 if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then
967 Bas := Full_View (Bas);
968 end if;
970 Disc := First_Discriminant (T);
972 if No (Discriminant_Default_Value (Disc)) then
973 return T;
974 end if;
976 declare
977 Act : constant Entity_Id := Make_Temporary (Loc, 'S');
978 Constraints : constant List_Id := New_List;
979 Decl : Node_Id;
981 begin
982 while Present (Disc) loop
983 Append_To (Constraints,
984 New_Copy_Tree (Discriminant_Default_Value (Disc)));
985 Next_Discriminant (Disc);
986 end loop;
988 Decl :=
989 Make_Subtype_Declaration (Loc,
990 Defining_Identifier => Act,
991 Subtype_Indication =>
992 Make_Subtype_Indication (Loc,
993 Subtype_Mark => New_Occurrence_Of (Bas, Loc),
994 Constraint =>
995 Make_Index_Or_Discriminant_Constraint (Loc,
996 Constraints => Constraints)));
998 Insert_Action (N, Decl);
999 Analyze (Decl);
1000 return Act;
1001 end;
1002 end Build_Default_Subtype;
1004 --------------------------------------------
1005 -- Build_Discriminal_Subtype_Of_Component --
1006 --------------------------------------------
1008 function Build_Discriminal_Subtype_Of_Component
1009 (T : Entity_Id) return Node_Id
1011 Loc : constant Source_Ptr := Sloc (T);
1012 D : Elmt_Id;
1013 Id : Node_Id;
1015 function Build_Discriminal_Array_Constraint return List_Id;
1016 -- If one or more of the bounds of the component depends on
1017 -- discriminants, build actual constraint using the discriminants
1018 -- of the prefix.
1020 function Build_Discriminal_Record_Constraint return List_Id;
1021 -- Similar to previous one, for discriminated components constrained by
1022 -- the discriminant of the enclosing object.
1024 ----------------------------------------
1025 -- Build_Discriminal_Array_Constraint --
1026 ----------------------------------------
1028 function Build_Discriminal_Array_Constraint return List_Id is
1029 Constraints : constant List_Id := New_List;
1030 Indx : Node_Id;
1031 Hi : Node_Id;
1032 Lo : Node_Id;
1033 Old_Hi : Node_Id;
1034 Old_Lo : Node_Id;
1036 begin
1037 Indx := First_Index (T);
1038 while Present (Indx) loop
1039 Old_Lo := Type_Low_Bound (Etype (Indx));
1040 Old_Hi := Type_High_Bound (Etype (Indx));
1042 if Denotes_Discriminant (Old_Lo) then
1043 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
1045 else
1046 Lo := New_Copy_Tree (Old_Lo);
1047 end if;
1049 if Denotes_Discriminant (Old_Hi) then
1050 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
1052 else
1053 Hi := New_Copy_Tree (Old_Hi);
1054 end if;
1056 Append (Make_Range (Loc, Lo, Hi), Constraints);
1057 Next_Index (Indx);
1058 end loop;
1060 return Constraints;
1061 end Build_Discriminal_Array_Constraint;
1063 -----------------------------------------
1064 -- Build_Discriminal_Record_Constraint --
1065 -----------------------------------------
1067 function Build_Discriminal_Record_Constraint return List_Id is
1068 Constraints : constant List_Id := New_List;
1069 D : Elmt_Id;
1070 D_Val : Node_Id;
1072 begin
1073 D := First_Elmt (Discriminant_Constraint (T));
1074 while Present (D) loop
1075 if Denotes_Discriminant (Node (D)) then
1076 D_Val :=
1077 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
1079 else
1080 D_Val := New_Copy_Tree (Node (D));
1081 end if;
1083 Append (D_Val, Constraints);
1084 Next_Elmt (D);
1085 end loop;
1087 return Constraints;
1088 end Build_Discriminal_Record_Constraint;
1090 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1092 begin
1093 if Ekind (T) = E_Array_Subtype then
1094 Id := First_Index (T);
1095 while Present (Id) loop
1096 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else
1097 Denotes_Discriminant (Type_High_Bound (Etype (Id)))
1098 then
1099 return Build_Component_Subtype
1100 (Build_Discriminal_Array_Constraint, Loc, T);
1101 end if;
1103 Next_Index (Id);
1104 end loop;
1106 elsif Ekind (T) = E_Record_Subtype
1107 and then Has_Discriminants (T)
1108 and then not Has_Unknown_Discriminants (T)
1109 then
1110 D := First_Elmt (Discriminant_Constraint (T));
1111 while Present (D) loop
1112 if Denotes_Discriminant (Node (D)) then
1113 return Build_Component_Subtype
1114 (Build_Discriminal_Record_Constraint, Loc, T);
1115 end if;
1117 Next_Elmt (D);
1118 end loop;
1119 end if;
1121 -- If none of the above, the actual and nominal subtypes are the same
1123 return Empty;
1124 end Build_Discriminal_Subtype_Of_Component;
1126 ------------------------------
1127 -- Build_Elaboration_Entity --
1128 ------------------------------
1130 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
1131 Loc : constant Source_Ptr := Sloc (N);
1132 Decl : Node_Id;
1133 Elab_Ent : Entity_Id;
1135 procedure Set_Package_Name (Ent : Entity_Id);
1136 -- Given an entity, sets the fully qualified name of the entity in
1137 -- Name_Buffer, with components separated by double underscores. This
1138 -- is a recursive routine that climbs the scope chain to Standard.
1140 ----------------------
1141 -- Set_Package_Name --
1142 ----------------------
1144 procedure Set_Package_Name (Ent : Entity_Id) is
1145 begin
1146 if Scope (Ent) /= Standard_Standard then
1147 Set_Package_Name (Scope (Ent));
1149 declare
1150 Nam : constant String := Get_Name_String (Chars (Ent));
1151 begin
1152 Name_Buffer (Name_Len + 1) := '_';
1153 Name_Buffer (Name_Len + 2) := '_';
1154 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
1155 Name_Len := Name_Len + Nam'Length + 2;
1156 end;
1158 else
1159 Get_Name_String (Chars (Ent));
1160 end if;
1161 end Set_Package_Name;
1163 -- Start of processing for Build_Elaboration_Entity
1165 begin
1166 -- Ignore if already constructed
1168 if Present (Elaboration_Entity (Spec_Id)) then
1169 return;
1170 end if;
1172 -- Ignore in ASIS mode, elaboration entity is not in source and plays
1173 -- no role in analysis.
1175 if ASIS_Mode then
1176 return;
1177 end if;
1179 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
1180 -- name with dots replaced by double underscore. We have to manually
1181 -- construct this name, since it will be elaborated in the outer scope,
1182 -- and thus will not have the unit name automatically prepended.
1184 Set_Package_Name (Spec_Id);
1185 Add_Str_To_Name_Buffer ("_E");
1187 -- Create elaboration counter
1189 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
1190 Set_Elaboration_Entity (Spec_Id, Elab_Ent);
1192 Decl :=
1193 Make_Object_Declaration (Loc,
1194 Defining_Identifier => Elab_Ent,
1195 Object_Definition =>
1196 New_Occurrence_Of (Standard_Short_Integer, Loc),
1197 Expression => Make_Integer_Literal (Loc, Uint_0));
1199 Push_Scope (Standard_Standard);
1200 Add_Global_Declaration (Decl);
1201 Pop_Scope;
1203 -- Reset True_Constant indication, since we will indeed assign a value
1204 -- to the variable in the binder main. We also kill the Current_Value
1205 -- and Last_Assignment fields for the same reason.
1207 Set_Is_True_Constant (Elab_Ent, False);
1208 Set_Current_Value (Elab_Ent, Empty);
1209 Set_Last_Assignment (Elab_Ent, Empty);
1211 -- We do not want any further qualification of the name (if we did not
1212 -- do this, we would pick up the name of the generic package in the case
1213 -- of a library level generic instantiation).
1215 Set_Has_Qualified_Name (Elab_Ent);
1216 Set_Has_Fully_Qualified_Name (Elab_Ent);
1217 end Build_Elaboration_Entity;
1219 --------------------------------
1220 -- Build_Explicit_Dereference --
1221 --------------------------------
1223 procedure Build_Explicit_Dereference
1224 (Expr : Node_Id;
1225 Disc : Entity_Id)
1227 Loc : constant Source_Ptr := Sloc (Expr);
1228 begin
1230 -- An entity of a type with a reference aspect is overloaded with
1231 -- both interpretations: with and without the dereference. Now that
1232 -- the dereference is made explicit, set the type of the node properly,
1233 -- to prevent anomalies in the backend. Same if the expression is an
1234 -- overloaded function call whose return type has a reference aspect.
1236 if Is_Entity_Name (Expr) then
1237 Set_Etype (Expr, Etype (Entity (Expr)));
1239 elsif Nkind (Expr) = N_Function_Call then
1240 Set_Etype (Expr, Etype (Name (Expr)));
1241 end if;
1243 Set_Is_Overloaded (Expr, False);
1244 Rewrite (Expr,
1245 Make_Explicit_Dereference (Loc,
1246 Prefix =>
1247 Make_Selected_Component (Loc,
1248 Prefix => Relocate_Node (Expr),
1249 Selector_Name => New_Occurrence_Of (Disc, Loc))));
1250 Set_Etype (Prefix (Expr), Etype (Disc));
1251 Set_Etype (Expr, Designated_Type (Etype (Disc)));
1252 end Build_Explicit_Dereference;
1254 -----------------------------------
1255 -- Cannot_Raise_Constraint_Error --
1256 -----------------------------------
1258 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
1259 begin
1260 if Compile_Time_Known_Value (Expr) then
1261 return True;
1263 elsif Do_Range_Check (Expr) then
1264 return False;
1266 elsif Raises_Constraint_Error (Expr) then
1267 return False;
1269 else
1270 case Nkind (Expr) is
1271 when N_Identifier =>
1272 return True;
1274 when N_Expanded_Name =>
1275 return True;
1277 when N_Selected_Component =>
1278 return not Do_Discriminant_Check (Expr);
1280 when N_Attribute_Reference =>
1281 if Do_Overflow_Check (Expr) then
1282 return False;
1284 elsif No (Expressions (Expr)) then
1285 return True;
1287 else
1288 declare
1289 N : Node_Id;
1291 begin
1292 N := First (Expressions (Expr));
1293 while Present (N) loop
1294 if Cannot_Raise_Constraint_Error (N) then
1295 Next (N);
1296 else
1297 return False;
1298 end if;
1299 end loop;
1301 return True;
1302 end;
1303 end if;
1305 when N_Type_Conversion =>
1306 if Do_Overflow_Check (Expr)
1307 or else Do_Length_Check (Expr)
1308 or else Do_Tag_Check (Expr)
1309 then
1310 return False;
1311 else
1312 return Cannot_Raise_Constraint_Error (Expression (Expr));
1313 end if;
1315 when N_Unchecked_Type_Conversion =>
1316 return Cannot_Raise_Constraint_Error (Expression (Expr));
1318 when N_Unary_Op =>
1319 if Do_Overflow_Check (Expr) then
1320 return False;
1321 else
1322 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1323 end if;
1325 when N_Op_Divide |
1326 N_Op_Mod |
1327 N_Op_Rem
1329 if Do_Division_Check (Expr)
1330 or else Do_Overflow_Check (Expr)
1331 then
1332 return False;
1333 else
1334 return
1335 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1336 and then
1337 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1338 end if;
1340 when N_Op_Add |
1341 N_Op_And |
1342 N_Op_Concat |
1343 N_Op_Eq |
1344 N_Op_Expon |
1345 N_Op_Ge |
1346 N_Op_Gt |
1347 N_Op_Le |
1348 N_Op_Lt |
1349 N_Op_Multiply |
1350 N_Op_Ne |
1351 N_Op_Or |
1352 N_Op_Rotate_Left |
1353 N_Op_Rotate_Right |
1354 N_Op_Shift_Left |
1355 N_Op_Shift_Right |
1356 N_Op_Shift_Right_Arithmetic |
1357 N_Op_Subtract |
1358 N_Op_Xor
1360 if Do_Overflow_Check (Expr) then
1361 return False;
1362 else
1363 return
1364 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1365 and then
1366 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1367 end if;
1369 when others =>
1370 return False;
1371 end case;
1372 end if;
1373 end Cannot_Raise_Constraint_Error;
1375 -----------------------------------------
1376 -- Check_Dynamically_Tagged_Expression --
1377 -----------------------------------------
1379 procedure Check_Dynamically_Tagged_Expression
1380 (Expr : Node_Id;
1381 Typ : Entity_Id;
1382 Related_Nod : Node_Id)
1384 begin
1385 pragma Assert (Is_Tagged_Type (Typ));
1387 -- In order to avoid spurious errors when analyzing the expanded code,
1388 -- this check is done only for nodes that come from source and for
1389 -- actuals of generic instantiations.
1391 if (Comes_From_Source (Related_Nod)
1392 or else In_Generic_Actual (Expr))
1393 and then (Is_Class_Wide_Type (Etype (Expr))
1394 or else Is_Dynamically_Tagged (Expr))
1395 and then Is_Tagged_Type (Typ)
1396 and then not Is_Class_Wide_Type (Typ)
1397 then
1398 Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
1399 end if;
1400 end Check_Dynamically_Tagged_Expression;
1402 -----------------------------------------------
1403 -- Check_Expression_Against_Static_Predicate --
1404 -----------------------------------------------
1406 procedure Check_Expression_Against_Static_Predicate
1407 (Expr : Node_Id;
1408 Typ : Entity_Id)
1410 begin
1411 -- When the predicate is static and the value of the expression is known
1412 -- at compile time, evaluate the predicate check. A type is non-static
1413 -- when it has aspect Dynamic_Predicate.
1415 if Compile_Time_Known_Value (Expr)
1416 and then Has_Predicates (Typ)
1417 and then Present (Static_Predicate (Typ))
1418 and then not Has_Dynamic_Predicate_Aspect (Typ)
1419 then
1420 -- Either -gnatc is enabled or the expression is ok
1422 if Operating_Mode < Generate_Code
1423 or else Eval_Static_Predicate_Check (Expr, Typ)
1424 then
1425 null;
1427 -- The expression is prohibited by the static predicate
1429 else
1430 Error_Msg_NE
1431 ("?static expression fails static predicate check on &",
1432 Expr, Typ);
1433 end if;
1434 end if;
1435 end Check_Expression_Against_Static_Predicate;
1437 --------------------------
1438 -- Check_Fully_Declared --
1439 --------------------------
1441 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
1442 begin
1443 if Ekind (T) = E_Incomplete_Type then
1445 -- Ada 2005 (AI-50217): If the type is available through a limited
1446 -- with_clause, verify that its full view has been analyzed.
1448 if From_Limited_With (T)
1449 and then Present (Non_Limited_View (T))
1450 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
1451 then
1452 -- The non-limited view is fully declared
1453 null;
1455 else
1456 Error_Msg_NE
1457 ("premature usage of incomplete}", N, First_Subtype (T));
1458 end if;
1460 -- Need comments for these tests ???
1462 elsif Has_Private_Component (T)
1463 and then not Is_Generic_Type (Root_Type (T))
1464 and then not In_Spec_Expression
1465 then
1466 -- Special case: if T is the anonymous type created for a single
1467 -- task or protected object, use the name of the source object.
1469 if Is_Concurrent_Type (T)
1470 and then not Comes_From_Source (T)
1471 and then Nkind (N) = N_Object_Declaration
1472 then
1473 Error_Msg_NE ("type of& has incomplete component", N,
1474 Defining_Identifier (N));
1476 else
1477 Error_Msg_NE
1478 ("premature usage of incomplete}", N, First_Subtype (T));
1479 end if;
1480 end if;
1481 end Check_Fully_Declared;
1483 -------------------------------------
1484 -- Check_Function_Writable_Actuals --
1485 -------------------------------------
1487 procedure Check_Function_Writable_Actuals (N : Node_Id) is
1488 Writable_Actuals_List : Elist_Id := No_Elist;
1489 Identifiers_List : Elist_Id := No_Elist;
1490 Error_Node : Node_Id := Empty;
1492 procedure Collect_Identifiers (N : Node_Id);
1493 -- In a single traversal of subtree N collect in Writable_Actuals_List
1494 -- all the actuals of functions with writable actuals, and in the list
1495 -- Identifiers_List collect all the identifiers that are not actuals of
1496 -- functions with writable actuals. If a writable actual is referenced
1497 -- twice as writable actual then Error_Node is set to reference its
1498 -- second occurrence, the error is reported, and the tree traversal
1499 -- is abandoned.
1501 function Get_Function_Id (Call : Node_Id) return Entity_Id;
1502 -- Return the entity associated with the function call
1504 procedure Preanalyze_Without_Errors (N : Node_Id);
1505 -- Preanalyze N without reporting errors. Very dubious, you can't just
1506 -- go analyzing things more than once???
1508 -------------------------
1509 -- Collect_Identifiers --
1510 -------------------------
1512 procedure Collect_Identifiers (N : Node_Id) is
1514 function Check_Node (N : Node_Id) return Traverse_Result;
1515 -- Process a single node during the tree traversal to collect the
1516 -- writable actuals of functions and all the identifiers which are
1517 -- not writable actuals of functions.
1519 function Contains (List : Elist_Id; N : Node_Id) return Boolean;
1520 -- Returns True if List has a node whose Entity is Entity (N)
1522 -------------------------
1523 -- Check_Function_Call --
1524 -------------------------
1526 function Check_Node (N : Node_Id) return Traverse_Result is
1527 Is_Writable_Actual : Boolean := False;
1529 begin
1530 if Nkind (N) = N_Identifier then
1532 -- No analysis possible if the entity is not decorated
1534 if No (Entity (N)) then
1535 return Skip;
1537 -- Don't collect identifiers of packages, called functions, etc
1539 elsif Ekind_In (Entity (N), E_Package,
1540 E_Function,
1541 E_Procedure,
1542 E_Entry)
1543 then
1544 return Skip;
1546 -- Analyze if N is a writable actual of a function
1548 elsif Nkind (Parent (N)) = N_Function_Call then
1549 declare
1550 Call : constant Node_Id := Parent (N);
1551 Id : constant Entity_Id := Get_Function_Id (Call);
1552 Actual : Node_Id;
1553 Formal : Node_Id;
1555 begin
1556 Formal := First_Formal (Id);
1557 Actual := First_Actual (Call);
1558 while Present (Actual) and then Present (Formal) loop
1559 if Actual = N then
1560 if Ekind_In (Formal, E_Out_Parameter,
1561 E_In_Out_Parameter)
1562 then
1563 Is_Writable_Actual := True;
1564 end if;
1566 exit;
1567 end if;
1569 Next_Formal (Formal);
1570 Next_Actual (Actual);
1571 end loop;
1572 end;
1573 end if;
1575 if Is_Writable_Actual then
1576 if Contains (Writable_Actuals_List, N) then
1577 Error_Msg_N
1578 ("conflict of writable function parameter in "
1579 & "construct with arbitrary order of evaluation", N);
1580 Error_Node := N;
1581 return Abandon;
1582 end if;
1584 if Writable_Actuals_List = No_Elist then
1585 Writable_Actuals_List := New_Elmt_List;
1586 end if;
1588 Append_Elmt (N, Writable_Actuals_List);
1589 else
1590 if Identifiers_List = No_Elist then
1591 Identifiers_List := New_Elmt_List;
1592 end if;
1594 Append_Unique_Elmt (N, Identifiers_List);
1595 end if;
1596 end if;
1598 return OK;
1599 end Check_Node;
1601 --------------
1602 -- Contains --
1603 --------------
1605 function Contains
1606 (List : Elist_Id;
1607 N : Node_Id) return Boolean
1609 pragma Assert (Nkind (N) in N_Has_Entity);
1611 Elmt : Elmt_Id;
1613 begin
1614 if List = No_Elist then
1615 return False;
1616 end if;
1618 Elmt := First_Elmt (List);
1619 while Present (Elmt) loop
1620 if Entity (Node (Elmt)) = Entity (N) then
1621 return True;
1622 else
1623 Next_Elmt (Elmt);
1624 end if;
1625 end loop;
1627 return False;
1628 end Contains;
1630 ------------------
1631 -- Do_Traversal --
1632 ------------------
1634 procedure Do_Traversal is new Traverse_Proc (Check_Node);
1635 -- The traversal procedure
1637 -- Start of processing for Collect_Identifiers
1639 begin
1640 if Present (Error_Node) then
1641 return;
1642 end if;
1644 if Nkind (N) in N_Subexpr
1645 and then Is_Static_Expression (N)
1646 then
1647 return;
1648 end if;
1650 Do_Traversal (N);
1651 end Collect_Identifiers;
1653 ---------------------
1654 -- Get_Function_Id --
1655 ---------------------
1657 function Get_Function_Id (Call : Node_Id) return Entity_Id is
1658 Nam : constant Node_Id := Name (Call);
1659 Id : Entity_Id;
1661 begin
1662 if Nkind (Nam) = N_Explicit_Dereference then
1663 Id := Etype (Nam);
1664 pragma Assert (Ekind (Id) = E_Subprogram_Type);
1666 elsif Nkind (Nam) = N_Selected_Component then
1667 Id := Entity (Selector_Name (Nam));
1669 elsif Nkind (Nam) = N_Indexed_Component then
1670 Id := Entity (Selector_Name (Prefix (Nam)));
1672 else
1673 Id := Entity (Nam);
1674 end if;
1676 return Id;
1677 end Get_Function_Id;
1679 ---------------------------
1680 -- Preanalyze_Expression --
1681 ---------------------------
1683 procedure Preanalyze_Without_Errors (N : Node_Id) is
1684 Status : constant Boolean := Get_Ignore_Errors;
1685 begin
1686 Set_Ignore_Errors (True);
1687 Preanalyze (N);
1688 Set_Ignore_Errors (Status);
1689 end Preanalyze_Without_Errors;
1691 -- Start of processing for Check_Function_Writable_Actuals
1693 begin
1694 if Ada_Version < Ada_2012
1695 or else (not (Nkind (N) in N_Op)
1696 and then not (Nkind (N) in N_Membership_Test)
1697 and then not Nkind_In (N, N_Range,
1698 N_Aggregate,
1699 N_Extension_Aggregate,
1700 N_Full_Type_Declaration,
1701 N_Function_Call,
1702 N_Procedure_Call_Statement,
1703 N_Entry_Call_Statement))
1704 or else (Nkind (N) = N_Full_Type_Declaration
1705 and then not Is_Record_Type (Defining_Identifier (N)))
1706 then
1707 return;
1708 end if;
1710 -- If a construct C has two or more direct constituents that are names
1711 -- or expressions whose evaluation may occur in an arbitrary order, at
1712 -- least one of which contains a function call with an in out or out
1713 -- parameter, then the construct is legal only if: for each name N that
1714 -- is passed as a parameter of mode in out or out to some inner function
1715 -- call C2 (not including the construct C itself), there is no other
1716 -- name anywhere within a direct constituent of the construct C other
1717 -- than the one containing C2, that is known to refer to the same
1718 -- object (RM 6.4.1(6.17/3)).
1720 case Nkind (N) is
1721 when N_Range =>
1722 Collect_Identifiers (Low_Bound (N));
1723 Collect_Identifiers (High_Bound (N));
1725 when N_Op | N_Membership_Test =>
1726 declare
1727 Expr : Node_Id;
1728 begin
1729 Collect_Identifiers (Left_Opnd (N));
1731 if Present (Right_Opnd (N)) then
1732 Collect_Identifiers (Right_Opnd (N));
1733 end if;
1735 if Nkind_In (N, N_In, N_Not_In)
1736 and then Present (Alternatives (N))
1737 then
1738 Expr := First (Alternatives (N));
1739 while Present (Expr) loop
1740 Collect_Identifiers (Expr);
1742 Next (Expr);
1743 end loop;
1744 end if;
1745 end;
1747 when N_Full_Type_Declaration =>
1748 declare
1749 function Get_Record_Part (N : Node_Id) return Node_Id;
1750 -- Return the record part of this record type definition
1752 function Get_Record_Part (N : Node_Id) return Node_Id is
1753 Type_Def : constant Node_Id := Type_Definition (N);
1754 begin
1755 if Nkind (Type_Def) = N_Derived_Type_Definition then
1756 return Record_Extension_Part (Type_Def);
1757 else
1758 return Type_Def;
1759 end if;
1760 end Get_Record_Part;
1762 Comp : Node_Id;
1763 Def_Id : Entity_Id := Defining_Identifier (N);
1764 Rec : Node_Id := Get_Record_Part (N);
1766 begin
1767 -- No need to perform any analysis if the record has no
1768 -- components
1770 if No (Rec) or else No (Component_List (Rec)) then
1771 return;
1772 end if;
1774 -- Collect the identifiers starting from the deepest
1775 -- derivation. Done to report the error in the deepest
1776 -- derivation.
1778 loop
1779 if Present (Component_List (Rec)) then
1780 Comp := First (Component_Items (Component_List (Rec)));
1781 while Present (Comp) loop
1782 if Nkind (Comp) = N_Component_Declaration
1783 and then Present (Expression (Comp))
1784 then
1785 Collect_Identifiers (Expression (Comp));
1786 end if;
1788 Next (Comp);
1789 end loop;
1790 end if;
1792 exit when No (Underlying_Type (Etype (Def_Id)))
1793 or else Base_Type (Underlying_Type (Etype (Def_Id)))
1794 = Def_Id;
1796 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
1797 Rec := Get_Record_Part (Parent (Def_Id));
1798 end loop;
1799 end;
1801 when N_Subprogram_Call |
1802 N_Entry_Call_Statement =>
1803 declare
1804 Id : constant Entity_Id := Get_Function_Id (N);
1805 Formal : Node_Id;
1806 Actual : Node_Id;
1808 begin
1809 Formal := First_Formal (Id);
1810 Actual := First_Actual (N);
1811 while Present (Actual) and then Present (Formal) loop
1812 if Ekind_In (Formal, E_Out_Parameter,
1813 E_In_Out_Parameter)
1814 then
1815 Collect_Identifiers (Actual);
1816 end if;
1818 Next_Formal (Formal);
1819 Next_Actual (Actual);
1820 end loop;
1821 end;
1823 when N_Aggregate |
1824 N_Extension_Aggregate =>
1825 declare
1826 Assoc : Node_Id;
1827 Choice : Node_Id;
1828 Comp_Expr : Node_Id;
1830 begin
1831 -- Handle the N_Others_Choice of array aggregates with static
1832 -- bounds. There is no need to perform this analysis in
1833 -- aggregates without static bounds since we cannot evaluate
1834 -- if the N_Others_Choice covers several elements. There is
1835 -- no need to handle the N_Others choice of record aggregates
1836 -- since at this stage it has been already expanded by
1837 -- Resolve_Record_Aggregate.
1839 if Is_Array_Type (Etype (N))
1840 and then Nkind (N) = N_Aggregate
1841 and then Present (Aggregate_Bounds (N))
1842 and then Compile_Time_Known_Bounds (Etype (N))
1843 and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
1844 > Expr_Value (Low_Bound (Aggregate_Bounds (N)))
1845 then
1846 declare
1847 Count_Components : Uint := Uint_0;
1848 Num_Components : Uint;
1849 Others_Assoc : Node_Id;
1850 Others_Choice : Node_Id := Empty;
1851 Others_Box_Present : Boolean := False;
1853 begin
1854 -- Count positional associations
1856 if Present (Expressions (N)) then
1857 Comp_Expr := First (Expressions (N));
1858 while Present (Comp_Expr) loop
1859 Count_Components := Count_Components + 1;
1860 Next (Comp_Expr);
1861 end loop;
1862 end if;
1864 -- Count the rest of elements and locate the N_Others
1865 -- choice (if any)
1867 Assoc := First (Component_Associations (N));
1868 while Present (Assoc) loop
1869 Choice := First (Choices (Assoc));
1870 while Present (Choice) loop
1871 if Nkind (Choice) = N_Others_Choice then
1872 Others_Assoc := Assoc;
1873 Others_Choice := Choice;
1874 Others_Box_Present := Box_Present (Assoc);
1876 -- Count several components
1878 elsif Nkind_In (Choice, N_Range,
1879 N_Subtype_Indication)
1880 or else (Is_Entity_Name (Choice)
1881 and then Is_Type (Entity (Choice)))
1882 then
1883 declare
1884 L, H : Node_Id;
1885 begin
1886 Get_Index_Bounds (Choice, L, H);
1887 pragma Assert
1888 (Compile_Time_Known_Value (L)
1889 and then Compile_Time_Known_Value (H));
1890 Count_Components :=
1891 Count_Components
1892 + Expr_Value (H) - Expr_Value (L) + 1;
1893 end;
1895 -- Count single component. No other case available
1896 -- since we are handling an aggregate with static
1897 -- bounds.
1899 else
1900 pragma Assert (Is_Static_Expression (Choice)
1901 or else Nkind (Choice) = N_Identifier
1902 or else Nkind (Choice) = N_Integer_Literal);
1904 Count_Components := Count_Components + 1;
1905 end if;
1907 Next (Choice);
1908 end loop;
1910 Next (Assoc);
1911 end loop;
1913 Num_Components :=
1914 Expr_Value (High_Bound (Aggregate_Bounds (N))) -
1915 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
1917 pragma Assert (Count_Components <= Num_Components);
1919 -- Handle the N_Others choice if it covers several
1920 -- components
1922 if Present (Others_Choice)
1923 and then (Num_Components - Count_Components) > 1
1924 then
1925 if not Others_Box_Present then
1927 -- At this stage, if expansion is active, the
1928 -- expression of the others choice has not been
1929 -- analyzed. Hence we generate a duplicate and
1930 -- we analyze it silently to have available the
1931 -- minimum decoration required to collect the
1932 -- identifiers.
1934 if not Expander_Active then
1935 Comp_Expr := Expression (Others_Assoc);
1936 else
1937 Comp_Expr :=
1938 New_Copy_Tree (Expression (Others_Assoc));
1939 Preanalyze_Without_Errors (Comp_Expr);
1940 end if;
1942 Collect_Identifiers (Comp_Expr);
1944 if Writable_Actuals_List /= No_Elist then
1946 -- As suggested by Robert, at current stage we
1947 -- report occurrences of this case as warnings.
1949 Error_Msg_N
1950 ("conflict of writable function parameter in "
1951 & "construct with arbitrary order of "
1952 & "evaluation?",
1953 Node (First_Elmt (Writable_Actuals_List)));
1954 end if;
1955 end if;
1956 end if;
1957 end;
1958 end if;
1960 -- Handle ancestor part of extension aggregates
1962 if Nkind (N) = N_Extension_Aggregate then
1963 Collect_Identifiers (Ancestor_Part (N));
1964 end if;
1966 -- Handle positional associations
1968 if Present (Expressions (N)) then
1969 Comp_Expr := First (Expressions (N));
1970 while Present (Comp_Expr) loop
1971 if not Is_Static_Expression (Comp_Expr) then
1972 Collect_Identifiers (Comp_Expr);
1973 end if;
1975 Next (Comp_Expr);
1976 end loop;
1977 end if;
1979 -- Handle discrete associations
1981 if Present (Component_Associations (N)) then
1982 Assoc := First (Component_Associations (N));
1983 while Present (Assoc) loop
1985 if not Box_Present (Assoc) then
1986 Choice := First (Choices (Assoc));
1987 while Present (Choice) loop
1989 -- For now we skip discriminants since it requires
1990 -- performing the analysis in two phases: first one
1991 -- analyzing discriminants and second one analyzing
1992 -- the rest of components since discriminants are
1993 -- evaluated prior to components: too much extra
1994 -- work to detect a corner case???
1996 if Nkind (Choice) in N_Has_Entity
1997 and then Present (Entity (Choice))
1998 and then Ekind (Entity (Choice)) = E_Discriminant
1999 then
2000 null;
2002 elsif Box_Present (Assoc) then
2003 null;
2005 else
2006 if not Analyzed (Expression (Assoc)) then
2007 Comp_Expr :=
2008 New_Copy_Tree (Expression (Assoc));
2009 Set_Parent (Comp_Expr, Parent (N));
2010 Preanalyze_Without_Errors (Comp_Expr);
2011 else
2012 Comp_Expr := Expression (Assoc);
2013 end if;
2015 Collect_Identifiers (Comp_Expr);
2016 end if;
2018 Next (Choice);
2019 end loop;
2020 end if;
2022 Next (Assoc);
2023 end loop;
2024 end if;
2025 end;
2027 when others =>
2028 return;
2029 end case;
2031 -- No further action needed if we already reported an error
2033 if Present (Error_Node) then
2034 return;
2035 end if;
2037 -- Check if some writable argument of a function is referenced
2039 if Writable_Actuals_List /= No_Elist
2040 and then Identifiers_List /= No_Elist
2041 then
2042 declare
2043 Elmt_1 : Elmt_Id;
2044 Elmt_2 : Elmt_Id;
2046 begin
2047 Elmt_1 := First_Elmt (Writable_Actuals_List);
2048 while Present (Elmt_1) loop
2049 Elmt_2 := First_Elmt (Identifiers_List);
2050 while Present (Elmt_2) loop
2051 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
2052 Error_Msg_N
2053 ("conflict of writable function parameter in construct "
2054 & "with arbitrary order of evaluation",
2055 Node (Elmt_1));
2056 end if;
2058 Next_Elmt (Elmt_2);
2059 end loop;
2061 Next_Elmt (Elmt_1);
2062 end loop;
2063 end;
2064 end if;
2065 end Check_Function_Writable_Actuals;
2067 --------------------------------
2068 -- Check_Implicit_Dereference --
2069 --------------------------------
2071 procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) is
2072 Disc : Entity_Id;
2073 Desig : Entity_Id;
2075 begin
2076 if Ada_Version < Ada_2012
2077 or else not Has_Implicit_Dereference (Base_Type (Typ))
2078 then
2079 return;
2081 elsif not Comes_From_Source (Nam) then
2082 return;
2084 elsif Is_Entity_Name (Nam)
2085 and then Is_Type (Entity (Nam))
2086 then
2087 null;
2089 else
2090 Disc := First_Discriminant (Typ);
2091 while Present (Disc) loop
2092 if Has_Implicit_Dereference (Disc) then
2093 Desig := Designated_Type (Etype (Disc));
2094 Add_One_Interp (Nam, Disc, Desig);
2095 exit;
2096 end if;
2098 Next_Discriminant (Disc);
2099 end loop;
2100 end if;
2101 end Check_Implicit_Dereference;
2103 ----------------------------------
2104 -- Check_Internal_Protected_Use --
2105 ----------------------------------
2107 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
2108 S : Entity_Id;
2109 Prot : Entity_Id;
2111 begin
2112 S := Current_Scope;
2113 while Present (S) loop
2114 if S = Standard_Standard then
2115 return;
2117 elsif Ekind (S) = E_Function
2118 and then Ekind (Scope (S)) = E_Protected_Type
2119 then
2120 Prot := Scope (S);
2121 exit;
2122 end if;
2124 S := Scope (S);
2125 end loop;
2127 if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then
2128 if Nkind (N) = N_Subprogram_Renaming_Declaration then
2129 Error_Msg_N
2130 ("within protected function cannot use protected "
2131 & "procedure in renaming or as generic actual", N);
2133 elsif Nkind (N) = N_Attribute_Reference then
2134 Error_Msg_N
2135 ("within protected function cannot take access of "
2136 & " protected procedure", N);
2138 else
2139 Error_Msg_N
2140 ("within protected function, protected object is constant", N);
2141 Error_Msg_N
2142 ("\cannot call operation that may modify it", N);
2143 end if;
2144 end if;
2145 end Check_Internal_Protected_Use;
2147 ---------------------------------------
2148 -- Check_Later_Vs_Basic_Declarations --
2149 ---------------------------------------
2151 procedure Check_Later_Vs_Basic_Declarations
2152 (Decls : List_Id;
2153 During_Parsing : Boolean)
2155 Body_Sloc : Source_Ptr;
2156 Decl : Node_Id;
2158 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
2159 -- Return whether Decl is considered as a declarative item.
2160 -- When During_Parsing is True, the semantics of Ada 83 is followed.
2161 -- When During_Parsing is False, the semantics of SPARK is followed.
2163 -------------------------------
2164 -- Is_Later_Declarative_Item --
2165 -------------------------------
2167 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
2168 begin
2169 if Nkind (Decl) in N_Later_Decl_Item then
2170 return True;
2172 elsif Nkind (Decl) = N_Pragma then
2173 return True;
2175 elsif During_Parsing then
2176 return False;
2178 -- In SPARK, a package declaration is not considered as a later
2179 -- declarative item.
2181 elsif Nkind (Decl) = N_Package_Declaration then
2182 return False;
2184 -- In SPARK, a renaming is considered as a later declarative item
2186 elsif Nkind (Decl) in N_Renaming_Declaration then
2187 return True;
2189 else
2190 return False;
2191 end if;
2192 end Is_Later_Declarative_Item;
2194 -- Start of Check_Later_Vs_Basic_Declarations
2196 begin
2197 Decl := First (Decls);
2199 -- Loop through sequence of basic declarative items
2201 Outer : while Present (Decl) loop
2202 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
2203 and then Nkind (Decl) not in N_Body_Stub
2204 then
2205 Next (Decl);
2207 -- Once a body is encountered, we only allow later declarative
2208 -- items. The inner loop checks the rest of the list.
2210 else
2211 Body_Sloc := Sloc (Decl);
2213 Inner : while Present (Decl) loop
2214 if not Is_Later_Declarative_Item (Decl) then
2215 if During_Parsing then
2216 if Ada_Version = Ada_83 then
2217 Error_Msg_Sloc := Body_Sloc;
2218 Error_Msg_N
2219 ("(Ada 83) decl cannot appear after body#", Decl);
2220 end if;
2221 else
2222 Error_Msg_Sloc := Body_Sloc;
2223 Check_SPARK_Restriction
2224 ("decl cannot appear after body#", Decl);
2225 end if;
2226 end if;
2228 Next (Decl);
2229 end loop Inner;
2230 end if;
2231 end loop Outer;
2232 end Check_Later_Vs_Basic_Declarations;
2234 -------------------------
2235 -- Check_Nested_Access --
2236 -------------------------
2238 procedure Check_Nested_Access (Ent : Entity_Id) is
2239 Scop : constant Entity_Id := Current_Scope;
2240 Current_Subp : Entity_Id;
2241 Enclosing : Entity_Id;
2243 begin
2244 -- Currently only enabled for VM back-ends for efficiency, should we
2245 -- enable it more systematically ???
2247 -- Check for Is_Imported needs commenting below ???
2249 if VM_Target /= No_VM
2250 and then (Ekind (Ent) = E_Variable
2251 or else
2252 Ekind (Ent) = E_Constant
2253 or else
2254 Ekind (Ent) = E_Loop_Parameter)
2255 and then Scope (Ent) /= Empty
2256 and then not Is_Library_Level_Entity (Ent)
2257 and then not Is_Imported (Ent)
2258 then
2259 if Is_Subprogram (Scop)
2260 or else Is_Generic_Subprogram (Scop)
2261 or else Is_Entry (Scop)
2262 then
2263 Current_Subp := Scop;
2264 else
2265 Current_Subp := Current_Subprogram;
2266 end if;
2268 Enclosing := Enclosing_Subprogram (Ent);
2270 if Enclosing /= Empty
2271 and then Enclosing /= Current_Subp
2272 then
2273 Set_Has_Up_Level_Access (Ent, True);
2274 end if;
2275 end if;
2276 end Check_Nested_Access;
2278 ---------------------------
2279 -- Check_No_Hidden_State --
2280 ---------------------------
2282 procedure Check_No_Hidden_State (Id : Entity_Id) is
2283 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean;
2284 -- Determine whether the entity of a package denoted by Pkg has a null
2285 -- abstract state.
2287 -----------------------------
2288 -- Has_Null_Abstract_State --
2289 -----------------------------
2291 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is
2292 States : constant Elist_Id := Abstract_States (Pkg);
2294 begin
2295 -- Check first available state of related package. A null abstract
2296 -- state always appears as the sole element of the state list.
2298 return
2299 Present (States)
2300 and then Is_Null_State (Node (First_Elmt (States)));
2301 end Has_Null_Abstract_State;
2303 -- Local variables
2305 Context : Entity_Id := Empty;
2306 Not_Visible : Boolean := False;
2307 Scop : Entity_Id;
2309 -- Start of processing for Check_No_Hidden_State
2311 begin
2312 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
2314 -- Find the proper context where the object or state appears
2316 Scop := Scope (Id);
2317 while Present (Scop) loop
2318 Context := Scop;
2320 -- Keep track of the context's visibility
2322 Not_Visible := Not_Visible or else In_Private_Part (Context);
2324 -- Prevent the search from going too far
2326 if Context = Standard_Standard then
2327 return;
2329 -- Objects and states that appear immediately within a subprogram or
2330 -- inside a construct nested within a subprogram do not introduce a
2331 -- hidden state. They behave as local variable declarations.
2333 elsif Is_Subprogram (Context) then
2334 return;
2336 -- When examining a package body, use the entity of the spec as it
2337 -- carries the abstract state declarations.
2339 elsif Ekind (Context) = E_Package_Body then
2340 Context := Spec_Entity (Context);
2341 end if;
2343 -- Stop the traversal when a package subject to a null abstract state
2344 -- has been found.
2346 if Ekind_In (Context, E_Generic_Package, E_Package)
2347 and then Has_Null_Abstract_State (Context)
2348 then
2349 exit;
2350 end if;
2352 Scop := Scope (Scop);
2353 end loop;
2355 -- At this point we know that there is at least one package with a null
2356 -- abstract state in visibility. Emit an error message unconditionally
2357 -- if the entity being processed is a state because the placement of the
2358 -- related package is irrelevant. This is not the case for objects as
2359 -- the intermediate context matters.
2361 if Present (Context)
2362 and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
2363 then
2364 Error_Msg_N ("cannot introduce hidden state &", Id);
2365 Error_Msg_NE ("\package & has null abstract state", Id, Context);
2366 end if;
2367 end Check_No_Hidden_State;
2369 ------------------------------------------
2370 -- Check_Potentially_Blocking_Operation --
2371 ------------------------------------------
2373 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
2374 S : Entity_Id;
2376 begin
2377 -- N is one of the potentially blocking operations listed in 9.5.1(8).
2378 -- When pragma Detect_Blocking is active, the run time will raise
2379 -- Program_Error. Here we only issue a warning, since we generally
2380 -- support the use of potentially blocking operations in the absence
2381 -- of the pragma.
2383 -- Indirect blocking through a subprogram call cannot be diagnosed
2384 -- statically without interprocedural analysis, so we do not attempt
2385 -- to do it here.
2387 S := Scope (Current_Scope);
2388 while Present (S) and then S /= Standard_Standard loop
2389 if Is_Protected_Type (S) then
2390 Error_Msg_N
2391 ("potentially blocking operation in protected operation??", N);
2392 return;
2393 end if;
2395 S := Scope (S);
2396 end loop;
2397 end Check_Potentially_Blocking_Operation;
2399 ------------------------------
2400 -- Check_Unprotected_Access --
2401 ------------------------------
2403 procedure Check_Unprotected_Access
2404 (Context : Node_Id;
2405 Expr : Node_Id)
2407 Cont_Encl_Typ : Entity_Id;
2408 Pref_Encl_Typ : Entity_Id;
2410 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
2411 -- Check whether Obj is a private component of a protected object.
2412 -- Return the protected type where the component resides, Empty
2413 -- otherwise.
2415 function Is_Public_Operation return Boolean;
2416 -- Verify that the enclosing operation is callable from outside the
2417 -- protected object, to minimize false positives.
2419 ------------------------------
2420 -- Enclosing_Protected_Type --
2421 ------------------------------
2423 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
2424 begin
2425 if Is_Entity_Name (Obj) then
2426 declare
2427 Ent : Entity_Id := Entity (Obj);
2429 begin
2430 -- The object can be a renaming of a private component, use
2431 -- the original record component.
2433 if Is_Prival (Ent) then
2434 Ent := Prival_Link (Ent);
2435 end if;
2437 if Is_Protected_Type (Scope (Ent)) then
2438 return Scope (Ent);
2439 end if;
2440 end;
2441 end if;
2443 -- For indexed and selected components, recursively check the prefix
2445 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
2446 return Enclosing_Protected_Type (Prefix (Obj));
2448 -- The object does not denote a protected component
2450 else
2451 return Empty;
2452 end if;
2453 end Enclosing_Protected_Type;
2455 -------------------------
2456 -- Is_Public_Operation --
2457 -------------------------
2459 function Is_Public_Operation return Boolean is
2460 S : Entity_Id;
2461 E : Entity_Id;
2463 begin
2464 S := Current_Scope;
2465 while Present (S)
2466 and then S /= Pref_Encl_Typ
2467 loop
2468 if Scope (S) = Pref_Encl_Typ then
2469 E := First_Entity (Pref_Encl_Typ);
2470 while Present (E)
2471 and then E /= First_Private_Entity (Pref_Encl_Typ)
2472 loop
2473 if E = S then
2474 return True;
2475 end if;
2476 Next_Entity (E);
2477 end loop;
2478 end if;
2480 S := Scope (S);
2481 end loop;
2483 return False;
2484 end Is_Public_Operation;
2486 -- Start of processing for Check_Unprotected_Access
2488 begin
2489 if Nkind (Expr) = N_Attribute_Reference
2490 and then Attribute_Name (Expr) = Name_Unchecked_Access
2491 then
2492 Cont_Encl_Typ := Enclosing_Protected_Type (Context);
2493 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
2495 -- Check whether we are trying to export a protected component to a
2496 -- context with an equal or lower access level.
2498 if Present (Pref_Encl_Typ)
2499 and then No (Cont_Encl_Typ)
2500 and then Is_Public_Operation
2501 and then Scope_Depth (Pref_Encl_Typ) >=
2502 Object_Access_Level (Context)
2503 then
2504 Error_Msg_N
2505 ("??possible unprotected access to protected data", Expr);
2506 end if;
2507 end if;
2508 end Check_Unprotected_Access;
2510 ---------------
2511 -- Check_VMS --
2512 ---------------
2514 procedure Check_VMS (Construct : Node_Id) is
2515 begin
2516 if not OpenVMS_On_Target then
2517 Error_Msg_N
2518 ("this construct is allowed only in Open'V'M'S", Construct);
2519 end if;
2520 end Check_VMS;
2522 ------------------------
2523 -- Collect_Interfaces --
2524 ------------------------
2526 procedure Collect_Interfaces
2527 (T : Entity_Id;
2528 Ifaces_List : out Elist_Id;
2529 Exclude_Parents : Boolean := False;
2530 Use_Full_View : Boolean := True)
2532 procedure Collect (Typ : Entity_Id);
2533 -- Subsidiary subprogram used to traverse the whole list
2534 -- of directly and indirectly implemented interfaces
2536 -------------
2537 -- Collect --
2538 -------------
2540 procedure Collect (Typ : Entity_Id) is
2541 Ancestor : Entity_Id;
2542 Full_T : Entity_Id;
2543 Id : Node_Id;
2544 Iface : Entity_Id;
2546 begin
2547 Full_T := Typ;
2549 -- Handle private types
2551 if Use_Full_View
2552 and then Is_Private_Type (Typ)
2553 and then Present (Full_View (Typ))
2554 then
2555 Full_T := Full_View (Typ);
2556 end if;
2558 -- Include the ancestor if we are generating the whole list of
2559 -- abstract interfaces.
2561 if Etype (Full_T) /= Typ
2563 -- Protect the frontend against wrong sources. For example:
2565 -- package P is
2566 -- type A is tagged null record;
2567 -- type B is new A with private;
2568 -- type C is new A with private;
2569 -- private
2570 -- type B is new C with null record;
2571 -- type C is new B with null record;
2572 -- end P;
2574 and then Etype (Full_T) /= T
2575 then
2576 Ancestor := Etype (Full_T);
2577 Collect (Ancestor);
2579 if Is_Interface (Ancestor)
2580 and then not Exclude_Parents
2581 then
2582 Append_Unique_Elmt (Ancestor, Ifaces_List);
2583 end if;
2584 end if;
2586 -- Traverse the graph of ancestor interfaces
2588 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
2589 Id := First (Abstract_Interface_List (Full_T));
2590 while Present (Id) loop
2591 Iface := Etype (Id);
2593 -- Protect against wrong uses. For example:
2594 -- type I is interface;
2595 -- type O is tagged null record;
2596 -- type Wrong is new I and O with null record; -- ERROR
2598 if Is_Interface (Iface) then
2599 if Exclude_Parents
2600 and then Etype (T) /= T
2601 and then Interface_Present_In_Ancestor (Etype (T), Iface)
2602 then
2603 null;
2604 else
2605 Collect (Iface);
2606 Append_Unique_Elmt (Iface, Ifaces_List);
2607 end if;
2608 end if;
2610 Next (Id);
2611 end loop;
2612 end if;
2613 end Collect;
2615 -- Start of processing for Collect_Interfaces
2617 begin
2618 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
2619 Ifaces_List := New_Elmt_List;
2620 Collect (T);
2621 end Collect_Interfaces;
2623 ----------------------------------
2624 -- Collect_Interface_Components --
2625 ----------------------------------
2627 procedure Collect_Interface_Components
2628 (Tagged_Type : Entity_Id;
2629 Components_List : out Elist_Id)
2631 procedure Collect (Typ : Entity_Id);
2632 -- Subsidiary subprogram used to climb to the parents
2634 -------------
2635 -- Collect --
2636 -------------
2638 procedure Collect (Typ : Entity_Id) is
2639 Tag_Comp : Entity_Id;
2640 Parent_Typ : Entity_Id;
2642 begin
2643 -- Handle private types
2645 if Present (Full_View (Etype (Typ))) then
2646 Parent_Typ := Full_View (Etype (Typ));
2647 else
2648 Parent_Typ := Etype (Typ);
2649 end if;
2651 if Parent_Typ /= Typ
2653 -- Protect the frontend against wrong sources. For example:
2655 -- package P is
2656 -- type A is tagged null record;
2657 -- type B is new A with private;
2658 -- type C is new A with private;
2659 -- private
2660 -- type B is new C with null record;
2661 -- type C is new B with null record;
2662 -- end P;
2664 and then Parent_Typ /= Tagged_Type
2665 then
2666 Collect (Parent_Typ);
2667 end if;
2669 -- Collect the components containing tags of secondary dispatch
2670 -- tables.
2672 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
2673 while Present (Tag_Comp) loop
2674 pragma Assert (Present (Related_Type (Tag_Comp)));
2675 Append_Elmt (Tag_Comp, Components_List);
2677 Tag_Comp := Next_Tag_Component (Tag_Comp);
2678 end loop;
2679 end Collect;
2681 -- Start of processing for Collect_Interface_Components
2683 begin
2684 pragma Assert (Ekind (Tagged_Type) = E_Record_Type
2685 and then Is_Tagged_Type (Tagged_Type));
2687 Components_List := New_Elmt_List;
2688 Collect (Tagged_Type);
2689 end Collect_Interface_Components;
2691 -----------------------------
2692 -- Collect_Interfaces_Info --
2693 -----------------------------
2695 procedure Collect_Interfaces_Info
2696 (T : Entity_Id;
2697 Ifaces_List : out Elist_Id;
2698 Components_List : out Elist_Id;
2699 Tags_List : out Elist_Id)
2701 Comps_List : Elist_Id;
2702 Comp_Elmt : Elmt_Id;
2703 Comp_Iface : Entity_Id;
2704 Iface_Elmt : Elmt_Id;
2705 Iface : Entity_Id;
2707 function Search_Tag (Iface : Entity_Id) return Entity_Id;
2708 -- Search for the secondary tag associated with the interface type
2709 -- Iface that is implemented by T.
2711 ----------------
2712 -- Search_Tag --
2713 ----------------
2715 function Search_Tag (Iface : Entity_Id) return Entity_Id is
2716 ADT : Elmt_Id;
2717 begin
2718 if not Is_CPP_Class (T) then
2719 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
2720 else
2721 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
2722 end if;
2724 while Present (ADT)
2725 and then Is_Tag (Node (ADT))
2726 and then Related_Type (Node (ADT)) /= Iface
2727 loop
2728 -- Skip secondary dispatch table referencing thunks to user
2729 -- defined primitives covered by this interface.
2731 pragma Assert (Has_Suffix (Node (ADT), 'P'));
2732 Next_Elmt (ADT);
2734 -- Skip secondary dispatch tables of Ada types
2736 if not Is_CPP_Class (T) then
2738 -- Skip secondary dispatch table referencing thunks to
2739 -- predefined primitives.
2741 pragma Assert (Has_Suffix (Node (ADT), 'Y'));
2742 Next_Elmt (ADT);
2744 -- Skip secondary dispatch table referencing user-defined
2745 -- primitives covered by this interface.
2747 pragma Assert (Has_Suffix (Node (ADT), 'D'));
2748 Next_Elmt (ADT);
2750 -- Skip secondary dispatch table referencing predefined
2751 -- primitives.
2753 pragma Assert (Has_Suffix (Node (ADT), 'Z'));
2754 Next_Elmt (ADT);
2755 end if;
2756 end loop;
2758 pragma Assert (Is_Tag (Node (ADT)));
2759 return Node (ADT);
2760 end Search_Tag;
2762 -- Start of processing for Collect_Interfaces_Info
2764 begin
2765 Collect_Interfaces (T, Ifaces_List);
2766 Collect_Interface_Components (T, Comps_List);
2768 -- Search for the record component and tag associated with each
2769 -- interface type of T.
2771 Components_List := New_Elmt_List;
2772 Tags_List := New_Elmt_List;
2774 Iface_Elmt := First_Elmt (Ifaces_List);
2775 while Present (Iface_Elmt) loop
2776 Iface := Node (Iface_Elmt);
2778 -- Associate the primary tag component and the primary dispatch table
2779 -- with all the interfaces that are parents of T
2781 if Is_Ancestor (Iface, T, Use_Full_View => True) then
2782 Append_Elmt (First_Tag_Component (T), Components_List);
2783 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
2785 -- Otherwise search for the tag component and secondary dispatch
2786 -- table of Iface
2788 else
2789 Comp_Elmt := First_Elmt (Comps_List);
2790 while Present (Comp_Elmt) loop
2791 Comp_Iface := Related_Type (Node (Comp_Elmt));
2793 if Comp_Iface = Iface
2794 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
2795 then
2796 Append_Elmt (Node (Comp_Elmt), Components_List);
2797 Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
2798 exit;
2799 end if;
2801 Next_Elmt (Comp_Elmt);
2802 end loop;
2803 pragma Assert (Present (Comp_Elmt));
2804 end if;
2806 Next_Elmt (Iface_Elmt);
2807 end loop;
2808 end Collect_Interfaces_Info;
2810 ---------------------
2811 -- Collect_Parents --
2812 ---------------------
2814 procedure Collect_Parents
2815 (T : Entity_Id;
2816 List : out Elist_Id;
2817 Use_Full_View : Boolean := True)
2819 Current_Typ : Entity_Id := T;
2820 Parent_Typ : Entity_Id;
2822 begin
2823 List := New_Elmt_List;
2825 -- No action if the if the type has no parents
2827 if T = Etype (T) then
2828 return;
2829 end if;
2831 loop
2832 Parent_Typ := Etype (Current_Typ);
2834 if Is_Private_Type (Parent_Typ)
2835 and then Present (Full_View (Parent_Typ))
2836 and then Use_Full_View
2837 then
2838 Parent_Typ := Full_View (Base_Type (Parent_Typ));
2839 end if;
2841 Append_Elmt (Parent_Typ, List);
2843 exit when Parent_Typ = Current_Typ;
2844 Current_Typ := Parent_Typ;
2845 end loop;
2846 end Collect_Parents;
2848 ----------------------------------
2849 -- Collect_Primitive_Operations --
2850 ----------------------------------
2852 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
2853 B_Type : constant Entity_Id := Base_Type (T);
2854 B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
2855 B_Scope : Entity_Id := Scope (B_Type);
2856 Op_List : Elist_Id;
2857 Formal : Entity_Id;
2858 Is_Prim : Boolean;
2859 Is_Type_In_Pkg : Boolean;
2860 Formal_Derived : Boolean := False;
2861 Id : Entity_Id;
2863 function Match (E : Entity_Id) return Boolean;
2864 -- True if E's base type is B_Type, or E is of an anonymous access type
2865 -- and the base type of its designated type is B_Type.
2867 -----------
2868 -- Match --
2869 -----------
2871 function Match (E : Entity_Id) return Boolean is
2872 Etyp : Entity_Id := Etype (E);
2874 begin
2875 if Ekind (Etyp) = E_Anonymous_Access_Type then
2876 Etyp := Designated_Type (Etyp);
2877 end if;
2879 return Base_Type (Etyp) = B_Type;
2880 end Match;
2882 -- Start of processing for Collect_Primitive_Operations
2884 begin
2885 -- For tagged types, the primitive operations are collected as they
2886 -- are declared, and held in an explicit list which is simply returned.
2888 if Is_Tagged_Type (B_Type) then
2889 return Primitive_Operations (B_Type);
2891 -- An untagged generic type that is a derived type inherits the
2892 -- primitive operations of its parent type. Other formal types only
2893 -- have predefined operators, which are not explicitly represented.
2895 elsif Is_Generic_Type (B_Type) then
2896 if Nkind (B_Decl) = N_Formal_Type_Declaration
2897 and then Nkind (Formal_Type_Definition (B_Decl))
2898 = N_Formal_Derived_Type_Definition
2899 then
2900 Formal_Derived := True;
2901 else
2902 return New_Elmt_List;
2903 end if;
2904 end if;
2906 Op_List := New_Elmt_List;
2908 if B_Scope = Standard_Standard then
2909 if B_Type = Standard_String then
2910 Append_Elmt (Standard_Op_Concat, Op_List);
2912 elsif B_Type = Standard_Wide_String then
2913 Append_Elmt (Standard_Op_Concatw, Op_List);
2915 else
2916 null;
2917 end if;
2919 -- Locate the primitive subprograms of the type
2921 else
2922 -- The primitive operations appear after the base type, except
2923 -- if the derivation happens within the private part of B_Scope
2924 -- and the type is a private type, in which case both the type
2925 -- and some primitive operations may appear before the base
2926 -- type, and the list of candidates starts after the type.
2928 if In_Open_Scopes (B_Scope)
2929 and then Scope (T) = B_Scope
2930 and then In_Private_Part (B_Scope)
2931 then
2932 Id := Next_Entity (T);
2933 else
2934 Id := Next_Entity (B_Type);
2935 end if;
2937 -- Set flag if this is a type in a package spec
2939 Is_Type_In_Pkg :=
2940 Is_Package_Or_Generic_Package (B_Scope)
2941 and then
2942 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
2943 N_Package_Body;
2945 while Present (Id) loop
2947 -- Test whether the result type or any of the parameter types of
2948 -- each subprogram following the type match that type when the
2949 -- type is declared in a package spec, is a derived type, or the
2950 -- subprogram is marked as primitive. (The Is_Primitive test is
2951 -- needed to find primitives of nonderived types in declarative
2952 -- parts that happen to override the predefined "=" operator.)
2954 -- Note that generic formal subprograms are not considered to be
2955 -- primitive operations and thus are never inherited.
2957 if Is_Overloadable (Id)
2958 and then (Is_Type_In_Pkg
2959 or else Is_Derived_Type (B_Type)
2960 or else Is_Primitive (Id))
2961 and then Nkind (Parent (Parent (Id)))
2962 not in N_Formal_Subprogram_Declaration
2963 then
2964 Is_Prim := False;
2966 if Match (Id) then
2967 Is_Prim := True;
2969 else
2970 Formal := First_Formal (Id);
2971 while Present (Formal) loop
2972 if Match (Formal) then
2973 Is_Prim := True;
2974 exit;
2975 end if;
2977 Next_Formal (Formal);
2978 end loop;
2979 end if;
2981 -- For a formal derived type, the only primitives are the ones
2982 -- inherited from the parent type. Operations appearing in the
2983 -- package declaration are not primitive for it.
2985 if Is_Prim
2986 and then (not Formal_Derived
2987 or else Present (Alias (Id)))
2988 then
2989 -- In the special case of an equality operator aliased to
2990 -- an overriding dispatching equality belonging to the same
2991 -- type, we don't include it in the list of primitives.
2992 -- This avoids inheriting multiple equality operators when
2993 -- deriving from untagged private types whose full type is
2994 -- tagged, which can otherwise cause ambiguities. Note that
2995 -- this should only happen for this kind of untagged parent
2996 -- type, since normally dispatching operations are inherited
2997 -- using the type's Primitive_Operations list.
2999 if Chars (Id) = Name_Op_Eq
3000 and then Is_Dispatching_Operation (Id)
3001 and then Present (Alias (Id))
3002 and then Present (Overridden_Operation (Alias (Id)))
3003 and then Base_Type (Etype (First_Entity (Id))) =
3004 Base_Type (Etype (First_Entity (Alias (Id))))
3005 then
3006 null;
3008 -- Include the subprogram in the list of primitives
3010 else
3011 Append_Elmt (Id, Op_List);
3012 end if;
3013 end if;
3014 end if;
3016 Next_Entity (Id);
3018 -- For a type declared in System, some of its operations may
3019 -- appear in the target-specific extension to System.
3021 if No (Id)
3022 and then B_Scope = RTU_Entity (System)
3023 and then Present_System_Aux
3024 then
3025 B_Scope := System_Aux_Id;
3026 Id := First_Entity (System_Aux_Id);
3027 end if;
3028 end loop;
3029 end if;
3031 return Op_List;
3032 end Collect_Primitive_Operations;
3034 -----------------------------------
3035 -- Compile_Time_Constraint_Error --
3036 -----------------------------------
3038 function Compile_Time_Constraint_Error
3039 (N : Node_Id;
3040 Msg : String;
3041 Ent : Entity_Id := Empty;
3042 Loc : Source_Ptr := No_Location;
3043 Warn : Boolean := False) return Node_Id
3045 Msgc : String (1 .. Msg'Length + 3);
3046 -- Copy of message, with room for possible ?? and ! at end
3048 Msgl : Natural;
3049 Wmsg : Boolean;
3050 P : Node_Id;
3051 OldP : Node_Id;
3052 Msgs : Boolean;
3053 Eloc : Source_Ptr;
3055 begin
3056 -- A static constraint error in an instance body is not a fatal error.
3057 -- we choose to inhibit the message altogether, because there is no
3058 -- obvious node (for now) on which to post it. On the other hand the
3059 -- offending node must be replaced with a constraint_error in any case.
3061 -- No messages are generated if we already posted an error on this node
3063 if not Error_Posted (N) then
3064 if Loc /= No_Location then
3065 Eloc := Loc;
3066 else
3067 Eloc := Sloc (N);
3068 end if;
3070 Msgc (1 .. Msg'Length) := Msg;
3071 Msgl := Msg'Length;
3073 -- Message is a warning, even in Ada 95 case
3075 if Msg (Msg'Last) = '?' then
3076 Wmsg := True;
3078 -- In Ada 83, all messages are warnings. In the private part and
3079 -- the body of an instance, constraint_checks are only warnings.
3080 -- We also make this a warning if the Warn parameter is set.
3082 elsif Warn
3083 or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
3084 then
3085 Msgl := Msgl + 1;
3086 Msgc (Msgl) := '?';
3087 Msgl := Msgl + 1;
3088 Msgc (Msgl) := '?';
3089 Wmsg := True;
3091 elsif In_Instance_Not_Visible then
3092 Msgl := Msgl + 1;
3093 Msgc (Msgl) := '?';
3094 Msgl := Msgl + 1;
3095 Msgc (Msgl) := '?';
3096 Wmsg := True;
3098 -- Otherwise we have a real error message (Ada 95 static case)
3099 -- and we make this an unconditional message. Note that in the
3100 -- warning case we do not make the message unconditional, it seems
3101 -- quite reasonable to delete messages like this (about exceptions
3102 -- that will be raised) in dead code.
3104 else
3105 Wmsg := False;
3106 Msgl := Msgl + 1;
3107 Msgc (Msgl) := '!';
3108 end if;
3110 -- Should we generate a warning? The answer is not quite yes. The
3111 -- very annoying exception occurs in the case of a short circuit
3112 -- operator where the left operand is static and decisive. Climb
3113 -- parents to see if that is the case we have here. Conditional
3114 -- expressions with decisive conditions are a similar situation.
3116 Msgs := True;
3117 P := N;
3118 loop
3119 OldP := P;
3120 P := Parent (P);
3122 -- And then with False as left operand
3124 if Nkind (P) = N_And_Then
3125 and then Compile_Time_Known_Value (Left_Opnd (P))
3126 and then Is_False (Expr_Value (Left_Opnd (P)))
3127 then
3128 Msgs := False;
3129 exit;
3131 -- OR ELSE with True as left operand
3133 elsif Nkind (P) = N_Or_Else
3134 and then Compile_Time_Known_Value (Left_Opnd (P))
3135 and then Is_True (Expr_Value (Left_Opnd (P)))
3136 then
3137 Msgs := False;
3138 exit;
3140 -- If expression
3142 elsif Nkind (P) = N_If_Expression then
3143 declare
3144 Cond : constant Node_Id := First (Expressions (P));
3145 Texp : constant Node_Id := Next (Cond);
3146 Fexp : constant Node_Id := Next (Texp);
3148 begin
3149 if Compile_Time_Known_Value (Cond) then
3151 -- Condition is True and we are in the right operand
3153 if Is_True (Expr_Value (Cond))
3154 and then OldP = Fexp
3155 then
3156 Msgs := False;
3157 exit;
3159 -- Condition is False and we are in the left operand
3161 elsif Is_False (Expr_Value (Cond))
3162 and then OldP = Texp
3163 then
3164 Msgs := False;
3165 exit;
3166 end if;
3167 end if;
3168 end;
3170 -- Special case for component association in aggregates, where
3171 -- we want to keep climbing up to the parent aggregate.
3173 elsif Nkind (P) = N_Component_Association
3174 and then Nkind (Parent (P)) = N_Aggregate
3175 then
3176 null;
3178 -- Keep going if within subexpression
3180 else
3181 exit when Nkind (P) not in N_Subexpr;
3182 end if;
3183 end loop;
3185 if Msgs then
3186 if Present (Ent) then
3187 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
3188 else
3189 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
3190 end if;
3192 if Wmsg then
3194 -- Check whether the context is an Init_Proc
3196 if Inside_Init_Proc then
3197 declare
3198 Conc_Typ : constant Entity_Id :=
3199 Corresponding_Concurrent_Type
3200 (Entity (Parameter_Type (First
3201 (Parameter_Specifications
3202 (Parent (Current_Scope))))));
3204 begin
3205 -- Don't complain if the corresponding concurrent type
3206 -- doesn't come from source (i.e. a single task/protected
3207 -- object).
3209 if Present (Conc_Typ)
3210 and then not Comes_From_Source (Conc_Typ)
3211 then
3212 Error_Msg_NEL
3213 ("\??& will be raised at run time",
3214 N, Standard_Constraint_Error, Eloc);
3216 else
3217 Error_Msg_NEL
3218 ("\??& will be raised for objects of this type",
3219 N, Standard_Constraint_Error, Eloc);
3220 end if;
3221 end;
3223 else
3224 Error_Msg_NEL
3225 ("\??& will be raised at run time",
3226 N, Standard_Constraint_Error, Eloc);
3227 end if;
3229 else
3230 Error_Msg
3231 ("\static expression fails Constraint_Check", Eloc);
3232 Set_Error_Posted (N);
3233 end if;
3234 end if;
3235 end if;
3237 return N;
3238 end Compile_Time_Constraint_Error;
3240 -----------------------
3241 -- Conditional_Delay --
3242 -----------------------
3244 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
3245 begin
3246 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
3247 Set_Has_Delayed_Freeze (New_Ent);
3248 end if;
3249 end Conditional_Delay;
3251 ----------------------------
3252 -- Contains_Refined_State --
3253 ----------------------------
3255 function Contains_Refined_State (Prag : Node_Id) return Boolean is
3256 function Has_State_In_Dependency (List : Node_Id) return Boolean;
3257 -- Determine whether a dependency list mentions a state with a visible
3258 -- refinement.
3260 function Has_State_In_Global (List : Node_Id) return Boolean;
3261 -- Determine whether a global list mentions a state with a visible
3262 -- refinement.
3264 function Is_Refined_State (Item : Node_Id) return Boolean;
3265 -- Determine whether Item is a reference to an abstract state with a
3266 -- visible refinement.
3268 -----------------------------
3269 -- Has_State_In_Dependency --
3270 -----------------------------
3272 function Has_State_In_Dependency (List : Node_Id) return Boolean is
3273 Clause : Node_Id;
3274 Output : Node_Id;
3276 begin
3277 -- A null dependency list does not mention any states
3279 if Nkind (List) = N_Null then
3280 return False;
3282 -- Dependency clauses appear as component associations of an
3283 -- aggregate.
3285 elsif Nkind (List) = N_Aggregate
3286 and then Present (Component_Associations (List))
3287 then
3288 Clause := First (Component_Associations (List));
3289 while Present (Clause) loop
3291 -- Inspect the outputs of a dependency clause
3293 Output := First (Choices (Clause));
3294 while Present (Output) loop
3295 if Is_Refined_State (Output) then
3296 return True;
3297 end if;
3299 Next (Output);
3300 end loop;
3302 -- Inspect the outputs of a dependency clause
3304 if Is_Refined_State (Expression (Clause)) then
3305 return True;
3306 end if;
3308 Next (Clause);
3309 end loop;
3311 -- If we get here, then none of the dependency clauses mention a
3312 -- state with visible refinement.
3314 return False;
3316 -- An illegal pragma managed to sneak in
3318 else
3319 raise Program_Error;
3320 end if;
3321 end Has_State_In_Dependency;
3323 -------------------------
3324 -- Has_State_In_Global --
3325 -------------------------
3327 function Has_State_In_Global (List : Node_Id) return Boolean is
3328 Item : Node_Id;
3330 begin
3331 -- A null global list does not mention any states
3333 if Nkind (List) = N_Null then
3334 return False;
3336 -- Simple global list or moded global list declaration
3338 elsif Nkind (List) = N_Aggregate then
3340 -- The declaration of a simple global list appear as a collection
3341 -- of expressions.
3343 if Present (Expressions (List)) then
3344 Item := First (Expressions (List));
3345 while Present (Item) loop
3346 if Is_Refined_State (Item) then
3347 return True;
3348 end if;
3350 Next (Item);
3351 end loop;
3353 -- The declaration of a moded global list appears as a collection
3354 -- of component associations where individual choices denote
3355 -- modes.
3357 else
3358 Item := First (Component_Associations (List));
3359 while Present (Item) loop
3360 if Has_State_In_Global (Expression (Item)) then
3361 return True;
3362 end if;
3364 Next (Item);
3365 end loop;
3366 end if;
3368 -- If we get here, then the simple/moded global list did not
3369 -- mention any states with a visible refinement.
3371 return False;
3373 -- Single global item declaration
3375 elsif Is_Entity_Name (List) then
3376 return Is_Refined_State (List);
3378 -- An illegal pragma managed to sneak in
3380 else
3381 raise Program_Error;
3382 end if;
3383 end Has_State_In_Global;
3385 ----------------------
3386 -- Is_Refined_State --
3387 ----------------------
3389 function Is_Refined_State (Item : Node_Id) return Boolean is
3390 Elmt : Node_Id;
3391 Item_Id : Entity_Id;
3393 begin
3394 if Nkind (Item) = N_Null then
3395 return False;
3397 -- States cannot be subject to attribute 'Result. This case arises
3398 -- in dependency relations.
3400 elsif Nkind (Item) = N_Attribute_Reference
3401 and then Attribute_Name (Item) = Name_Result
3402 then
3403 return False;
3405 -- Multiple items appear as an aggregate. This case arises in
3406 -- dependency relations.
3408 elsif Nkind (Item) = N_Aggregate
3409 and then Present (Expressions (Item))
3410 then
3411 Elmt := First (Expressions (Item));
3412 while Present (Elmt) loop
3413 if Is_Refined_State (Elmt) then
3414 return True;
3415 end if;
3417 Next (Elmt);
3418 end loop;
3420 -- If we get here, then none of the inputs or outputs reference a
3421 -- state with visible refinement.
3423 return False;
3425 -- Single item
3427 else
3428 Item_Id := Entity_Of (Item);
3430 return
3431 Ekind (Item_Id) = E_Abstract_State
3432 and then Has_Visible_Refinement (Item_Id);
3433 end if;
3434 end Is_Refined_State;
3436 -- Local variables
3438 Arg : constant Node_Id :=
3439 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
3440 Nam : constant Name_Id := Pragma_Name (Prag);
3442 -- Start of processing for Contains_Refined_State
3444 begin
3445 if Nam = Name_Depends then
3446 return Has_State_In_Dependency (Arg);
3448 else pragma Assert (Nam = Name_Global);
3449 return Has_State_In_Global (Arg);
3450 end if;
3451 end Contains_Refined_State;
3453 -------------------------
3454 -- Copy_Component_List --
3455 -------------------------
3457 function Copy_Component_List
3458 (R_Typ : Entity_Id;
3459 Loc : Source_Ptr) return List_Id
3461 Comp : Node_Id;
3462 Comps : constant List_Id := New_List;
3464 begin
3465 Comp := First_Component (Underlying_Type (R_Typ));
3466 while Present (Comp) loop
3467 if Comes_From_Source (Comp) then
3468 declare
3469 Comp_Decl : constant Node_Id := Declaration_Node (Comp);
3470 begin
3471 Append_To (Comps,
3472 Make_Component_Declaration (Loc,
3473 Defining_Identifier =>
3474 Make_Defining_Identifier (Loc, Chars (Comp)),
3475 Component_Definition =>
3476 New_Copy_Tree
3477 (Component_Definition (Comp_Decl), New_Sloc => Loc)));
3478 end;
3479 end if;
3481 Next_Component (Comp);
3482 end loop;
3484 return Comps;
3485 end Copy_Component_List;
3487 -------------------------
3488 -- Copy_Parameter_List --
3489 -------------------------
3491 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
3492 Loc : constant Source_Ptr := Sloc (Subp_Id);
3493 Plist : List_Id;
3494 Formal : Entity_Id;
3496 begin
3497 if No (First_Formal (Subp_Id)) then
3498 return No_List;
3499 else
3500 Plist := New_List;
3501 Formal := First_Formal (Subp_Id);
3502 while Present (Formal) loop
3503 Append
3504 (Make_Parameter_Specification (Loc,
3505 Defining_Identifier =>
3506 Make_Defining_Identifier (Sloc (Formal),
3507 Chars => Chars (Formal)),
3508 In_Present => In_Present (Parent (Formal)),
3509 Out_Present => Out_Present (Parent (Formal)),
3510 Parameter_Type =>
3511 New_Reference_To (Etype (Formal), Loc),
3512 Expression =>
3513 New_Copy_Tree (Expression (Parent (Formal)))),
3514 Plist);
3516 Next_Formal (Formal);
3517 end loop;
3518 end if;
3520 return Plist;
3521 end Copy_Parameter_List;
3523 --------------------------------
3524 -- Corresponding_Generic_Type --
3525 --------------------------------
3527 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
3528 Inst : Entity_Id;
3529 Gen : Entity_Id;
3530 Typ : Entity_Id;
3532 begin
3533 if not Is_Generic_Actual_Type (T) then
3534 return Any_Type;
3536 -- If the actual is the actual of an enclosing instance, resolution
3537 -- was correct in the generic.
3539 elsif Nkind (Parent (T)) = N_Subtype_Declaration
3540 and then Is_Entity_Name (Subtype_Indication (Parent (T)))
3541 and then
3542 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T))))
3543 then
3544 return Any_Type;
3546 else
3547 Inst := Scope (T);
3549 if Is_Wrapper_Package (Inst) then
3550 Inst := Related_Instance (Inst);
3551 end if;
3553 Gen :=
3554 Generic_Parent
3555 (Specification (Unit_Declaration_Node (Inst)));
3557 -- Generic actual has the same name as the corresponding formal
3559 Typ := First_Entity (Gen);
3560 while Present (Typ) loop
3561 if Chars (Typ) = Chars (T) then
3562 return Typ;
3563 end if;
3565 Next_Entity (Typ);
3566 end loop;
3568 return Any_Type;
3569 end if;
3570 end Corresponding_Generic_Type;
3572 --------------------
3573 -- Current_Entity --
3574 --------------------
3576 -- The currently visible definition for a given identifier is the
3577 -- one most chained at the start of the visibility chain, i.e. the
3578 -- one that is referenced by the Node_Id value of the name of the
3579 -- given identifier.
3581 function Current_Entity (N : Node_Id) return Entity_Id is
3582 begin
3583 return Get_Name_Entity_Id (Chars (N));
3584 end Current_Entity;
3586 -----------------------------
3587 -- Current_Entity_In_Scope --
3588 -----------------------------
3590 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
3591 E : Entity_Id;
3592 CS : constant Entity_Id := Current_Scope;
3594 Transient_Case : constant Boolean := Scope_Is_Transient;
3596 begin
3597 E := Get_Name_Entity_Id (Chars (N));
3598 while Present (E)
3599 and then Scope (E) /= CS
3600 and then (not Transient_Case or else Scope (E) /= Scope (CS))
3601 loop
3602 E := Homonym (E);
3603 end loop;
3605 return E;
3606 end Current_Entity_In_Scope;
3608 -------------------
3609 -- Current_Scope --
3610 -------------------
3612 function Current_Scope return Entity_Id is
3613 begin
3614 if Scope_Stack.Last = -1 then
3615 return Standard_Standard;
3616 else
3617 declare
3618 C : constant Entity_Id :=
3619 Scope_Stack.Table (Scope_Stack.Last).Entity;
3620 begin
3621 if Present (C) then
3622 return C;
3623 else
3624 return Standard_Standard;
3625 end if;
3626 end;
3627 end if;
3628 end Current_Scope;
3630 ------------------------
3631 -- Current_Subprogram --
3632 ------------------------
3634 function Current_Subprogram return Entity_Id is
3635 Scop : constant Entity_Id := Current_Scope;
3636 begin
3637 if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
3638 return Scop;
3639 else
3640 return Enclosing_Subprogram (Scop);
3641 end if;
3642 end Current_Subprogram;
3644 ----------------------------------
3645 -- Deepest_Type_Access_Level --
3646 ----------------------------------
3648 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
3649 begin
3650 if Ekind (Typ) = E_Anonymous_Access_Type
3651 and then not Is_Local_Anonymous_Access (Typ)
3652 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
3653 then
3654 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
3655 -- access type.
3657 return
3658 Scope_Depth (Enclosing_Dynamic_Scope
3659 (Defining_Identifier
3660 (Associated_Node_For_Itype (Typ))));
3662 -- For generic formal type, return Int'Last (infinite).
3663 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
3665 elsif Is_Generic_Type (Root_Type (Typ)) then
3666 return UI_From_Int (Int'Last);
3668 else
3669 return Type_Access_Level (Typ);
3670 end if;
3671 end Deepest_Type_Access_Level;
3673 ---------------------
3674 -- Defining_Entity --
3675 ---------------------
3677 function Defining_Entity (N : Node_Id) return Entity_Id is
3678 K : constant Node_Kind := Nkind (N);
3679 Err : Entity_Id := Empty;
3681 begin
3682 case K is
3683 when
3684 N_Subprogram_Declaration |
3685 N_Abstract_Subprogram_Declaration |
3686 N_Subprogram_Body |
3687 N_Package_Declaration |
3688 N_Subprogram_Renaming_Declaration |
3689 N_Subprogram_Body_Stub |
3690 N_Generic_Subprogram_Declaration |
3691 N_Generic_Package_Declaration |
3692 N_Formal_Subprogram_Declaration |
3693 N_Expression_Function
3695 return Defining_Entity (Specification (N));
3697 when
3698 N_Component_Declaration |
3699 N_Defining_Program_Unit_Name |
3700 N_Discriminant_Specification |
3701 N_Entry_Body |
3702 N_Entry_Declaration |
3703 N_Entry_Index_Specification |
3704 N_Exception_Declaration |
3705 N_Exception_Renaming_Declaration |
3706 N_Formal_Object_Declaration |
3707 N_Formal_Package_Declaration |
3708 N_Formal_Type_Declaration |
3709 N_Full_Type_Declaration |
3710 N_Implicit_Label_Declaration |
3711 N_Incomplete_Type_Declaration |
3712 N_Loop_Parameter_Specification |
3713 N_Number_Declaration |
3714 N_Object_Declaration |
3715 N_Object_Renaming_Declaration |
3716 N_Package_Body_Stub |
3717 N_Parameter_Specification |
3718 N_Private_Extension_Declaration |
3719 N_Private_Type_Declaration |
3720 N_Protected_Body |
3721 N_Protected_Body_Stub |
3722 N_Protected_Type_Declaration |
3723 N_Single_Protected_Declaration |
3724 N_Single_Task_Declaration |
3725 N_Subtype_Declaration |
3726 N_Task_Body |
3727 N_Task_Body_Stub |
3728 N_Task_Type_Declaration
3730 return Defining_Identifier (N);
3732 when N_Subunit =>
3733 return Defining_Entity (Proper_Body (N));
3735 when
3736 N_Function_Instantiation |
3737 N_Function_Specification |
3738 N_Generic_Function_Renaming_Declaration |
3739 N_Generic_Package_Renaming_Declaration |
3740 N_Generic_Procedure_Renaming_Declaration |
3741 N_Package_Body |
3742 N_Package_Instantiation |
3743 N_Package_Renaming_Declaration |
3744 N_Package_Specification |
3745 N_Procedure_Instantiation |
3746 N_Procedure_Specification
3748 declare
3749 Nam : constant Node_Id := Defining_Unit_Name (N);
3751 begin
3752 if Nkind (Nam) in N_Entity then
3753 return Nam;
3755 -- For Error, make up a name and attach to declaration
3756 -- so we can continue semantic analysis
3758 elsif Nam = Error then
3759 Err := Make_Temporary (Sloc (N), 'T');
3760 Set_Defining_Unit_Name (N, Err);
3762 return Err;
3763 -- If not an entity, get defining identifier
3765 else
3766 return Defining_Identifier (Nam);
3767 end if;
3768 end;
3770 when N_Block_Statement =>
3771 return Entity (Identifier (N));
3773 when others =>
3774 raise Program_Error;
3776 end case;
3777 end Defining_Entity;
3779 --------------------------
3780 -- Denotes_Discriminant --
3781 --------------------------
3783 function Denotes_Discriminant
3784 (N : Node_Id;
3785 Check_Concurrent : Boolean := False) return Boolean
3787 E : Entity_Id;
3788 begin
3789 if not Is_Entity_Name (N)
3790 or else No (Entity (N))
3791 then
3792 return False;
3793 else
3794 E := Entity (N);
3795 end if;
3797 -- If we are checking for a protected type, the discriminant may have
3798 -- been rewritten as the corresponding discriminal of the original type
3799 -- or of the corresponding concurrent record, depending on whether we
3800 -- are in the spec or body of the protected type.
3802 return Ekind (E) = E_Discriminant
3803 or else
3804 (Check_Concurrent
3805 and then Ekind (E) = E_In_Parameter
3806 and then Present (Discriminal_Link (E))
3807 and then
3808 (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
3809 or else
3810 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
3812 end Denotes_Discriminant;
3814 -------------------------
3815 -- Denotes_Same_Object --
3816 -------------------------
3818 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
3819 Obj1 : Node_Id := A1;
3820 Obj2 : Node_Id := A2;
3822 function Has_Prefix (N : Node_Id) return Boolean;
3823 -- Return True if N has attribute Prefix
3825 function Is_Renaming (N : Node_Id) return Boolean;
3826 -- Return true if N names a renaming entity
3828 function Is_Valid_Renaming (N : Node_Id) return Boolean;
3829 -- For renamings, return False if the prefix of any dereference within
3830 -- the renamed object_name is a variable, or any expression within the
3831 -- renamed object_name contains references to variables or calls on
3832 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
3834 ----------------
3835 -- Has_Prefix --
3836 ----------------
3838 function Has_Prefix (N : Node_Id) return Boolean is
3839 begin
3840 return
3841 Nkind_In (N,
3842 N_Attribute_Reference,
3843 N_Expanded_Name,
3844 N_Explicit_Dereference,
3845 N_Indexed_Component,
3846 N_Reference,
3847 N_Selected_Component,
3848 N_Slice);
3849 end Has_Prefix;
3851 -----------------
3852 -- Is_Renaming --
3853 -----------------
3855 function Is_Renaming (N : Node_Id) return Boolean is
3856 begin
3857 return Is_Entity_Name (N)
3858 and then Present (Renamed_Entity (Entity (N)));
3859 end Is_Renaming;
3861 -----------------------
3862 -- Is_Valid_Renaming --
3863 -----------------------
3865 function Is_Valid_Renaming (N : Node_Id) return Boolean is
3867 function Check_Renaming (N : Node_Id) return Boolean;
3868 -- Recursive function used to traverse all the prefixes of N
3870 function Check_Renaming (N : Node_Id) return Boolean is
3871 begin
3872 if Is_Renaming (N)
3873 and then not Check_Renaming (Renamed_Entity (Entity (N)))
3874 then
3875 return False;
3876 end if;
3878 if Nkind (N) = N_Indexed_Component then
3879 declare
3880 Indx : Node_Id;
3882 begin
3883 Indx := First (Expressions (N));
3884 while Present (Indx) loop
3885 if not Is_OK_Static_Expression (Indx) then
3886 return False;
3887 end if;
3889 Next_Index (Indx);
3890 end loop;
3891 end;
3892 end if;
3894 if Has_Prefix (N) then
3895 declare
3896 P : constant Node_Id := Prefix (N);
3898 begin
3899 if Nkind (N) = N_Explicit_Dereference
3900 and then Is_Variable (P)
3901 then
3902 return False;
3904 elsif Is_Entity_Name (P)
3905 and then Ekind (Entity (P)) = E_Function
3906 then
3907 return False;
3909 elsif Nkind (P) = N_Function_Call then
3910 return False;
3911 end if;
3913 -- Recursion to continue traversing the prefix of the
3914 -- renaming expression
3916 return Check_Renaming (P);
3917 end;
3918 end if;
3920 return True;
3921 end Check_Renaming;
3923 -- Start of processing for Is_Valid_Renaming
3925 begin
3926 return Check_Renaming (N);
3927 end Is_Valid_Renaming;
3929 -- Start of processing for Denotes_Same_Object
3931 begin
3932 -- Both names statically denote the same stand-alone object or parameter
3933 -- (RM 6.4.1(6.5/3))
3935 if Is_Entity_Name (Obj1)
3936 and then Is_Entity_Name (Obj2)
3937 and then Entity (Obj1) = Entity (Obj2)
3938 then
3939 return True;
3940 end if;
3942 -- For renamings, the prefix of any dereference within the renamed
3943 -- object_name is not a variable, and any expression within the
3944 -- renamed object_name contains no references to variables nor
3945 -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
3947 if Is_Renaming (Obj1) then
3948 if Is_Valid_Renaming (Obj1) then
3949 Obj1 := Renamed_Entity (Entity (Obj1));
3950 else
3951 return False;
3952 end if;
3953 end if;
3955 if Is_Renaming (Obj2) then
3956 if Is_Valid_Renaming (Obj2) then
3957 Obj2 := Renamed_Entity (Entity (Obj2));
3958 else
3959 return False;
3960 end if;
3961 end if;
3963 -- No match if not same node kind (such cases are handled by
3964 -- Denotes_Same_Prefix)
3966 if Nkind (Obj1) /= Nkind (Obj2) then
3967 return False;
3969 -- After handling valid renamings, one of the two names statically
3970 -- denoted a renaming declaration whose renamed object_name is known
3971 -- to denote the same object as the other (RM 6.4.1(6.10/3))
3973 elsif Is_Entity_Name (Obj1) then
3974 if Is_Entity_Name (Obj2) then
3975 return Entity (Obj1) = Entity (Obj2);
3976 else
3977 return False;
3978 end if;
3980 -- Both names are selected_components, their prefixes are known to
3981 -- denote the same object, and their selector_names denote the same
3982 -- component (RM 6.4.1(6.6/3)
3984 elsif Nkind (Obj1) = N_Selected_Component then
3985 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
3986 and then
3987 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
3989 -- Both names are dereferences and the dereferenced names are known to
3990 -- denote the same object (RM 6.4.1(6.7/3))
3992 elsif Nkind (Obj1) = N_Explicit_Dereference then
3993 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
3995 -- Both names are indexed_components, their prefixes are known to denote
3996 -- the same object, and each of the pairs of corresponding index values
3997 -- are either both static expressions with the same static value or both
3998 -- names that are known to denote the same object (RM 6.4.1(6.8/3))
4000 elsif Nkind (Obj1) = N_Indexed_Component then
4001 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
4002 return False;
4003 else
4004 declare
4005 Indx1 : Node_Id;
4006 Indx2 : Node_Id;
4008 begin
4009 Indx1 := First (Expressions (Obj1));
4010 Indx2 := First (Expressions (Obj2));
4011 while Present (Indx1) loop
4013 -- Indexes must denote the same static value or same object
4015 if Is_OK_Static_Expression (Indx1) then
4016 if not Is_OK_Static_Expression (Indx2) then
4017 return False;
4019 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
4020 return False;
4021 end if;
4023 elsif not Denotes_Same_Object (Indx1, Indx2) then
4024 return False;
4025 end if;
4027 Next (Indx1);
4028 Next (Indx2);
4029 end loop;
4031 return True;
4032 end;
4033 end if;
4035 -- Both names are slices, their prefixes are known to denote the same
4036 -- object, and the two slices have statically matching index constraints
4037 -- (RM 6.4.1(6.9/3))
4039 elsif Nkind (Obj1) = N_Slice
4040 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
4041 then
4042 declare
4043 Lo1, Lo2, Hi1, Hi2 : Node_Id;
4045 begin
4046 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
4047 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
4049 -- Check whether bounds are statically identical. There is no
4050 -- attempt to detect partial overlap of slices.
4052 return Denotes_Same_Object (Lo1, Lo2)
4053 and then Denotes_Same_Object (Hi1, Hi2);
4054 end;
4056 -- In the recursion, literals appear as indexes.
4058 elsif Nkind (Obj1) = N_Integer_Literal
4059 and then Nkind (Obj2) = N_Integer_Literal
4060 then
4061 return Intval (Obj1) = Intval (Obj2);
4063 else
4064 return False;
4065 end if;
4066 end Denotes_Same_Object;
4068 -------------------------
4069 -- Denotes_Same_Prefix --
4070 -------------------------
4072 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
4074 begin
4075 if Is_Entity_Name (A1) then
4076 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
4077 and then not Is_Access_Type (Etype (A1))
4078 then
4079 return Denotes_Same_Object (A1, Prefix (A2))
4080 or else Denotes_Same_Prefix (A1, Prefix (A2));
4081 else
4082 return False;
4083 end if;
4085 elsif Is_Entity_Name (A2) then
4086 return Denotes_Same_Prefix (A1 => A2, A2 => A1);
4088 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
4089 and then
4090 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
4091 then
4092 declare
4093 Root1, Root2 : Node_Id;
4094 Depth1, Depth2 : Int := 0;
4096 begin
4097 Root1 := Prefix (A1);
4098 while not Is_Entity_Name (Root1) loop
4099 if not Nkind_In
4100 (Root1, N_Selected_Component, N_Indexed_Component)
4101 then
4102 return False;
4103 else
4104 Root1 := Prefix (Root1);
4105 end if;
4107 Depth1 := Depth1 + 1;
4108 end loop;
4110 Root2 := Prefix (A2);
4111 while not Is_Entity_Name (Root2) loop
4112 if not Nkind_In
4113 (Root2, N_Selected_Component, N_Indexed_Component)
4114 then
4115 return False;
4116 else
4117 Root2 := Prefix (Root2);
4118 end if;
4120 Depth2 := Depth2 + 1;
4121 end loop;
4123 -- If both have the same depth and they do not denote the same
4124 -- object, they are disjoint and no warning is needed.
4126 if Depth1 = Depth2 then
4127 return False;
4129 elsif Depth1 > Depth2 then
4130 Root1 := Prefix (A1);
4131 for I in 1 .. Depth1 - Depth2 - 1 loop
4132 Root1 := Prefix (Root1);
4133 end loop;
4135 return Denotes_Same_Object (Root1, A2);
4137 else
4138 Root2 := Prefix (A2);
4139 for I in 1 .. Depth2 - Depth1 - 1 loop
4140 Root2 := Prefix (Root2);
4141 end loop;
4143 return Denotes_Same_Object (A1, Root2);
4144 end if;
4145 end;
4147 else
4148 return False;
4149 end if;
4150 end Denotes_Same_Prefix;
4152 ----------------------
4153 -- Denotes_Variable --
4154 ----------------------
4156 function Denotes_Variable (N : Node_Id) return Boolean is
4157 begin
4158 return Is_Variable (N) and then Paren_Count (N) = 0;
4159 end Denotes_Variable;
4161 -----------------------------
4162 -- Depends_On_Discriminant --
4163 -----------------------------
4165 function Depends_On_Discriminant (N : Node_Id) return Boolean is
4166 L : Node_Id;
4167 H : Node_Id;
4169 begin
4170 Get_Index_Bounds (N, L, H);
4171 return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
4172 end Depends_On_Discriminant;
4174 -------------------------
4175 -- Designate_Same_Unit --
4176 -------------------------
4178 function Designate_Same_Unit
4179 (Name1 : Node_Id;
4180 Name2 : Node_Id) return Boolean
4182 K1 : constant Node_Kind := Nkind (Name1);
4183 K2 : constant Node_Kind := Nkind (Name2);
4185 function Prefix_Node (N : Node_Id) return Node_Id;
4186 -- Returns the parent unit name node of a defining program unit name
4187 -- or the prefix if N is a selected component or an expanded name.
4189 function Select_Node (N : Node_Id) return Node_Id;
4190 -- Returns the defining identifier node of a defining program unit
4191 -- name or the selector node if N is a selected component or an
4192 -- expanded name.
4194 -----------------
4195 -- Prefix_Node --
4196 -----------------
4198 function Prefix_Node (N : Node_Id) return Node_Id is
4199 begin
4200 if Nkind (N) = N_Defining_Program_Unit_Name then
4201 return Name (N);
4203 else
4204 return Prefix (N);
4205 end if;
4206 end Prefix_Node;
4208 -----------------
4209 -- Select_Node --
4210 -----------------
4212 function Select_Node (N : Node_Id) return Node_Id is
4213 begin
4214 if Nkind (N) = N_Defining_Program_Unit_Name then
4215 return Defining_Identifier (N);
4217 else
4218 return Selector_Name (N);
4219 end if;
4220 end Select_Node;
4222 -- Start of processing for Designate_Next_Unit
4224 begin
4225 if (K1 = N_Identifier or else
4226 K1 = N_Defining_Identifier)
4227 and then
4228 (K2 = N_Identifier or else
4229 K2 = N_Defining_Identifier)
4230 then
4231 return Chars (Name1) = Chars (Name2);
4233 elsif
4234 (K1 = N_Expanded_Name or else
4235 K1 = N_Selected_Component or else
4236 K1 = N_Defining_Program_Unit_Name)
4237 and then
4238 (K2 = N_Expanded_Name or else
4239 K2 = N_Selected_Component or else
4240 K2 = N_Defining_Program_Unit_Name)
4241 then
4242 return
4243 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
4244 and then
4245 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
4247 else
4248 return False;
4249 end if;
4250 end Designate_Same_Unit;
4252 ------------------------------------------
4253 -- function Dynamic_Accessibility_Level --
4254 ------------------------------------------
4256 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
4257 E : Entity_Id;
4258 Loc : constant Source_Ptr := Sloc (Expr);
4260 function Make_Level_Literal (Level : Uint) return Node_Id;
4261 -- Construct an integer literal representing an accessibility level
4262 -- with its type set to Natural.
4264 ------------------------
4265 -- Make_Level_Literal --
4266 ------------------------
4268 function Make_Level_Literal (Level : Uint) return Node_Id is
4269 Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
4270 begin
4271 Set_Etype (Result, Standard_Natural);
4272 return Result;
4273 end Make_Level_Literal;
4275 -- Start of processing for Dynamic_Accessibility_Level
4277 begin
4278 if Is_Entity_Name (Expr) then
4279 E := Entity (Expr);
4281 if Present (Renamed_Object (E)) then
4282 return Dynamic_Accessibility_Level (Renamed_Object (E));
4283 end if;
4285 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
4286 if Present (Extra_Accessibility (E)) then
4287 return New_Occurrence_Of (Extra_Accessibility (E), Loc);
4288 end if;
4289 end if;
4290 end if;
4292 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
4294 case Nkind (Expr) is
4296 -- For access discriminant, the level of the enclosing object
4298 when N_Selected_Component =>
4299 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
4300 and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
4301 E_Anonymous_Access_Type
4302 then
4303 return Make_Level_Literal (Object_Access_Level (Expr));
4304 end if;
4306 when N_Attribute_Reference =>
4307 case Get_Attribute_Id (Attribute_Name (Expr)) is
4309 -- For X'Access, the level of the prefix X
4311 when Attribute_Access =>
4312 return Make_Level_Literal
4313 (Object_Access_Level (Prefix (Expr)));
4315 -- Treat the unchecked attributes as library-level
4317 when Attribute_Unchecked_Access |
4318 Attribute_Unrestricted_Access =>
4319 return Make_Level_Literal (Scope_Depth (Standard_Standard));
4321 -- No other access-valued attributes
4323 when others =>
4324 raise Program_Error;
4325 end case;
4327 when N_Allocator =>
4329 -- Unimplemented: depends on context. As an actual parameter where
4330 -- formal type is anonymous, use
4331 -- Scope_Depth (Current_Scope) + 1.
4332 -- For other cases, see 3.10.2(14/3) and following. ???
4334 null;
4336 when N_Type_Conversion =>
4337 if not Is_Local_Anonymous_Access (Etype (Expr)) then
4339 -- Handle type conversions introduced for a rename of an
4340 -- Ada 2012 stand-alone object of an anonymous access type.
4342 return Dynamic_Accessibility_Level (Expression (Expr));
4343 end if;
4345 when others =>
4346 null;
4347 end case;
4349 return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
4350 end Dynamic_Accessibility_Level;
4352 -----------------------------------
4353 -- Effective_Extra_Accessibility --
4354 -----------------------------------
4356 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
4357 begin
4358 if Present (Renamed_Object (Id))
4359 and then Is_Entity_Name (Renamed_Object (Id))
4360 then
4361 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
4362 else
4363 return Extra_Accessibility (Id);
4364 end if;
4365 end Effective_Extra_Accessibility;
4367 ------------------------------
4368 -- Enclosing_Comp_Unit_Node --
4369 ------------------------------
4371 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
4372 Current_Node : Node_Id;
4374 begin
4375 Current_Node := N;
4376 while Present (Current_Node)
4377 and then Nkind (Current_Node) /= N_Compilation_Unit
4378 loop
4379 Current_Node := Parent (Current_Node);
4380 end loop;
4382 if Nkind (Current_Node) /= N_Compilation_Unit then
4383 return Empty;
4384 else
4385 return Current_Node;
4386 end if;
4387 end Enclosing_Comp_Unit_Node;
4389 --------------------------
4390 -- Enclosing_CPP_Parent --
4391 --------------------------
4393 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
4394 Parent_Typ : Entity_Id := Typ;
4396 begin
4397 while not Is_CPP_Class (Parent_Typ)
4398 and then Etype (Parent_Typ) /= Parent_Typ
4399 loop
4400 Parent_Typ := Etype (Parent_Typ);
4402 if Is_Private_Type (Parent_Typ) then
4403 Parent_Typ := Full_View (Base_Type (Parent_Typ));
4404 end if;
4405 end loop;
4407 pragma Assert (Is_CPP_Class (Parent_Typ));
4408 return Parent_Typ;
4409 end Enclosing_CPP_Parent;
4411 ----------------------------
4412 -- Enclosing_Generic_Body --
4413 ----------------------------
4415 function Enclosing_Generic_Body
4416 (N : Node_Id) return Node_Id
4418 P : Node_Id;
4419 Decl : Node_Id;
4420 Spec : Node_Id;
4422 begin
4423 P := Parent (N);
4424 while Present (P) loop
4425 if Nkind (P) = N_Package_Body
4426 or else Nkind (P) = N_Subprogram_Body
4427 then
4428 Spec := Corresponding_Spec (P);
4430 if Present (Spec) then
4431 Decl := Unit_Declaration_Node (Spec);
4433 if Nkind (Decl) = N_Generic_Package_Declaration
4434 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
4435 then
4436 return P;
4437 end if;
4438 end if;
4439 end if;
4441 P := Parent (P);
4442 end loop;
4444 return Empty;
4445 end Enclosing_Generic_Body;
4447 ----------------------------
4448 -- Enclosing_Generic_Unit --
4449 ----------------------------
4451 function Enclosing_Generic_Unit
4452 (N : Node_Id) return Node_Id
4454 P : Node_Id;
4455 Decl : Node_Id;
4456 Spec : Node_Id;
4458 begin
4459 P := Parent (N);
4460 while Present (P) loop
4461 if Nkind (P) = N_Generic_Package_Declaration
4462 or else Nkind (P) = N_Generic_Subprogram_Declaration
4463 then
4464 return P;
4466 elsif Nkind (P) = N_Package_Body
4467 or else Nkind (P) = N_Subprogram_Body
4468 then
4469 Spec := Corresponding_Spec (P);
4471 if Present (Spec) then
4472 Decl := Unit_Declaration_Node (Spec);
4474 if Nkind (Decl) = N_Generic_Package_Declaration
4475 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
4476 then
4477 return Decl;
4478 end if;
4479 end if;
4480 end if;
4482 P := Parent (P);
4483 end loop;
4485 return Empty;
4486 end Enclosing_Generic_Unit;
4488 -------------------------------
4489 -- Enclosing_Lib_Unit_Entity --
4490 -------------------------------
4492 function Enclosing_Lib_Unit_Entity
4493 (E : Entity_Id := Current_Scope) return Entity_Id
4495 Unit_Entity : Entity_Id;
4497 begin
4498 -- Look for enclosing library unit entity by following scope links.
4499 -- Equivalent to, but faster than indexing through the scope stack.
4501 Unit_Entity := E;
4502 while (Present (Scope (Unit_Entity))
4503 and then Scope (Unit_Entity) /= Standard_Standard)
4504 and not Is_Child_Unit (Unit_Entity)
4505 loop
4506 Unit_Entity := Scope (Unit_Entity);
4507 end loop;
4509 return Unit_Entity;
4510 end Enclosing_Lib_Unit_Entity;
4512 -----------------------
4513 -- Enclosing_Package --
4514 -----------------------
4516 function Enclosing_Package (E : Entity_Id) return Entity_Id is
4517 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
4519 begin
4520 if Dynamic_Scope = Standard_Standard then
4521 return Standard_Standard;
4523 elsif Dynamic_Scope = Empty then
4524 return Empty;
4526 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
4527 E_Generic_Package)
4528 then
4529 return Dynamic_Scope;
4531 else
4532 return Enclosing_Package (Dynamic_Scope);
4533 end if;
4534 end Enclosing_Package;
4536 --------------------------
4537 -- Enclosing_Subprogram --
4538 --------------------------
4540 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
4541 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
4543 begin
4544 if Dynamic_Scope = Standard_Standard then
4545 return Empty;
4547 elsif Dynamic_Scope = Empty then
4548 return Empty;
4550 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
4551 return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
4553 elsif Ekind (Dynamic_Scope) = E_Block
4554 or else Ekind (Dynamic_Scope) = E_Return_Statement
4555 then
4556 return Enclosing_Subprogram (Dynamic_Scope);
4558 elsif Ekind (Dynamic_Scope) = E_Task_Type then
4559 return Get_Task_Body_Procedure (Dynamic_Scope);
4561 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
4562 and then Present (Full_View (Dynamic_Scope))
4563 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
4564 then
4565 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
4567 -- No body is generated if the protected operation is eliminated
4569 elsif Convention (Dynamic_Scope) = Convention_Protected
4570 and then not Is_Eliminated (Dynamic_Scope)
4571 and then Present (Protected_Body_Subprogram (Dynamic_Scope))
4572 then
4573 return Protected_Body_Subprogram (Dynamic_Scope);
4575 else
4576 return Dynamic_Scope;
4577 end if;
4578 end Enclosing_Subprogram;
4580 ------------------------
4581 -- Ensure_Freeze_Node --
4582 ------------------------
4584 procedure Ensure_Freeze_Node (E : Entity_Id) is
4585 FN : Node_Id;
4586 begin
4587 if No (Freeze_Node (E)) then
4588 FN := Make_Freeze_Entity (Sloc (E));
4589 Set_Has_Delayed_Freeze (E);
4590 Set_Freeze_Node (E, FN);
4591 Set_Access_Types_To_Process (FN, No_Elist);
4592 Set_TSS_Elist (FN, No_Elist);
4593 Set_Entity (FN, E);
4594 end if;
4595 end Ensure_Freeze_Node;
4597 ----------------
4598 -- Enter_Name --
4599 ----------------
4601 procedure Enter_Name (Def_Id : Entity_Id) is
4602 C : constant Entity_Id := Current_Entity (Def_Id);
4603 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
4604 S : constant Entity_Id := Current_Scope;
4606 begin
4607 Generate_Definition (Def_Id);
4609 -- Add new name to current scope declarations. Check for duplicate
4610 -- declaration, which may or may not be a genuine error.
4612 if Present (E) then
4614 -- Case of previous entity entered because of a missing declaration
4615 -- or else a bad subtype indication. Best is to use the new entity,
4616 -- and make the previous one invisible.
4618 if Etype (E) = Any_Type then
4619 Set_Is_Immediately_Visible (E, False);
4621 -- Case of renaming declaration constructed for package instances.
4622 -- if there is an explicit declaration with the same identifier,
4623 -- the renaming is not immediately visible any longer, but remains
4624 -- visible through selected component notation.
4626 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
4627 and then not Comes_From_Source (E)
4628 then
4629 Set_Is_Immediately_Visible (E, False);
4631 -- The new entity may be the package renaming, which has the same
4632 -- same name as a generic formal which has been seen already.
4634 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
4635 and then not Comes_From_Source (Def_Id)
4636 then
4637 Set_Is_Immediately_Visible (E, False);
4639 -- For a fat pointer corresponding to a remote access to subprogram,
4640 -- we use the same identifier as the RAS type, so that the proper
4641 -- name appears in the stub. This type is only retrieved through
4642 -- the RAS type and never by visibility, and is not added to the
4643 -- visibility list (see below).
4645 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
4646 and then Present (Corresponding_Remote_Type (Def_Id))
4647 then
4648 null;
4650 -- Case of an implicit operation or derived literal. The new entity
4651 -- hides the implicit one, which is removed from all visibility,
4652 -- i.e. the entity list of its scope, and homonym chain of its name.
4654 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
4655 or else Is_Internal (E)
4656 then
4657 declare
4658 Prev : Entity_Id;
4659 Prev_Vis : Entity_Id;
4660 Decl : constant Node_Id := Parent (E);
4662 begin
4663 -- If E is an implicit declaration, it cannot be the first
4664 -- entity in the scope.
4666 Prev := First_Entity (Current_Scope);
4667 while Present (Prev)
4668 and then Next_Entity (Prev) /= E
4669 loop
4670 Next_Entity (Prev);
4671 end loop;
4673 if No (Prev) then
4675 -- If E is not on the entity chain of the current scope,
4676 -- it is an implicit declaration in the generic formal
4677 -- part of a generic subprogram. When analyzing the body,
4678 -- the generic formals are visible but not on the entity
4679 -- chain of the subprogram. The new entity will become
4680 -- the visible one in the body.
4682 pragma Assert
4683 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
4684 null;
4686 else
4687 Set_Next_Entity (Prev, Next_Entity (E));
4689 if No (Next_Entity (Prev)) then
4690 Set_Last_Entity (Current_Scope, Prev);
4691 end if;
4693 if E = Current_Entity (E) then
4694 Prev_Vis := Empty;
4696 else
4697 Prev_Vis := Current_Entity (E);
4698 while Homonym (Prev_Vis) /= E loop
4699 Prev_Vis := Homonym (Prev_Vis);
4700 end loop;
4701 end if;
4703 if Present (Prev_Vis) then
4705 -- Skip E in the visibility chain
4707 Set_Homonym (Prev_Vis, Homonym (E));
4709 else
4710 Set_Name_Entity_Id (Chars (E), Homonym (E));
4711 end if;
4712 end if;
4713 end;
4715 -- This section of code could use a comment ???
4717 elsif Present (Etype (E))
4718 and then Is_Concurrent_Type (Etype (E))
4719 and then E = Def_Id
4720 then
4721 return;
4723 -- If the homograph is a protected component renaming, it should not
4724 -- be hiding the current entity. Such renamings are treated as weak
4725 -- declarations.
4727 elsif Is_Prival (E) then
4728 Set_Is_Immediately_Visible (E, False);
4730 -- In this case the current entity is a protected component renaming.
4731 -- Perform minimal decoration by setting the scope and return since
4732 -- the prival should not be hiding other visible entities.
4734 elsif Is_Prival (Def_Id) then
4735 Set_Scope (Def_Id, Current_Scope);
4736 return;
4738 -- Analogous to privals, the discriminal generated for an entry index
4739 -- parameter acts as a weak declaration. Perform minimal decoration
4740 -- to avoid bogus errors.
4742 elsif Is_Discriminal (Def_Id)
4743 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
4744 then
4745 Set_Scope (Def_Id, Current_Scope);
4746 return;
4748 -- In the body or private part of an instance, a type extension may
4749 -- introduce a component with the same name as that of an actual. The
4750 -- legality rule is not enforced, but the semantics of the full type
4751 -- with two components of same name are not clear at this point???
4753 elsif In_Instance_Not_Visible then
4754 null;
4756 -- When compiling a package body, some child units may have become
4757 -- visible. They cannot conflict with local entities that hide them.
4759 elsif Is_Child_Unit (E)
4760 and then In_Open_Scopes (Scope (E))
4761 and then not Is_Immediately_Visible (E)
4762 then
4763 null;
4765 -- Conversely, with front-end inlining we may compile the parent body
4766 -- first, and a child unit subsequently. The context is now the
4767 -- parent spec, and body entities are not visible.
4769 elsif Is_Child_Unit (Def_Id)
4770 and then Is_Package_Body_Entity (E)
4771 and then not In_Package_Body (Current_Scope)
4772 then
4773 null;
4775 -- Case of genuine duplicate declaration
4777 else
4778 Error_Msg_Sloc := Sloc (E);
4780 -- If the previous declaration is an incomplete type declaration
4781 -- this may be an attempt to complete it with a private type. The
4782 -- following avoids confusing cascaded errors.
4784 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
4785 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
4786 then
4787 Error_Msg_N
4788 ("incomplete type cannot be completed with a private " &
4789 "declaration", Parent (Def_Id));
4790 Set_Is_Immediately_Visible (E, False);
4791 Set_Full_View (E, Def_Id);
4793 -- An inherited component of a record conflicts with a new
4794 -- discriminant. The discriminant is inserted first in the scope,
4795 -- but the error should be posted on it, not on the component.
4797 elsif Ekind (E) = E_Discriminant
4798 and then Present (Scope (Def_Id))
4799 and then Scope (Def_Id) /= Current_Scope
4800 then
4801 Error_Msg_Sloc := Sloc (Def_Id);
4802 Error_Msg_N ("& conflicts with declaration#", E);
4803 return;
4805 -- If the name of the unit appears in its own context clause, a
4806 -- dummy package with the name has already been created, and the
4807 -- error emitted. Try to continue quietly.
4809 elsif Error_Posted (E)
4810 and then Sloc (E) = No_Location
4811 and then Nkind (Parent (E)) = N_Package_Specification
4812 and then Current_Scope = Standard_Standard
4813 then
4814 Set_Scope (Def_Id, Current_Scope);
4815 return;
4817 else
4818 Error_Msg_N ("& conflicts with declaration#", Def_Id);
4820 -- Avoid cascaded messages with duplicate components in
4821 -- derived types.
4823 if Ekind_In (E, E_Component, E_Discriminant) then
4824 return;
4825 end if;
4826 end if;
4828 if Nkind (Parent (Parent (Def_Id))) =
4829 N_Generic_Subprogram_Declaration
4830 and then Def_Id =
4831 Defining_Entity (Specification (Parent (Parent (Def_Id))))
4832 then
4833 Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
4834 end if;
4836 -- If entity is in standard, then we are in trouble, because it
4837 -- means that we have a library package with a duplicated name.
4838 -- That's hard to recover from, so abort!
4840 if S = Standard_Standard then
4841 raise Unrecoverable_Error;
4843 -- Otherwise we continue with the declaration. Having two
4844 -- identical declarations should not cause us too much trouble!
4846 else
4847 null;
4848 end if;
4849 end if;
4850 end if;
4852 -- If we fall through, declaration is OK, at least OK enough to continue
4854 -- If Def_Id is a discriminant or a record component we are in the midst
4855 -- of inheriting components in a derived record definition. Preserve
4856 -- their Ekind and Etype.
4858 if Ekind_In (Def_Id, E_Discriminant, E_Component) then
4859 null;
4861 -- If a type is already set, leave it alone (happens when a type
4862 -- declaration is reanalyzed following a call to the optimizer).
4864 elsif Present (Etype (Def_Id)) then
4865 null;
4867 -- Otherwise, the kind E_Void insures that premature uses of the entity
4868 -- will be detected. Any_Type insures that no cascaded errors will occur
4870 else
4871 Set_Ekind (Def_Id, E_Void);
4872 Set_Etype (Def_Id, Any_Type);
4873 end if;
4875 -- Inherited discriminants and components in derived record types are
4876 -- immediately visible. Itypes are not.
4878 -- Unless the Itype is for a record type with a corresponding remote
4879 -- type (what is that about, it was not commented ???)
4881 if Ekind_In (Def_Id, E_Discriminant, E_Component)
4882 or else
4883 ((not Is_Record_Type (Def_Id)
4884 or else No (Corresponding_Remote_Type (Def_Id)))
4885 and then not Is_Itype (Def_Id))
4886 then
4887 Set_Is_Immediately_Visible (Def_Id);
4888 Set_Current_Entity (Def_Id);
4889 end if;
4891 Set_Homonym (Def_Id, C);
4892 Append_Entity (Def_Id, S);
4893 Set_Public_Status (Def_Id);
4895 -- Declaring a homonym is not allowed in SPARK ...
4897 if Present (C)
4898 and then Restriction_Check_Required (SPARK_05)
4899 then
4900 declare
4901 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
4902 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
4903 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C);
4905 begin
4906 -- ... unless the new declaration is in a subprogram, and the
4907 -- visible declaration is a variable declaration or a parameter
4908 -- specification outside that subprogram.
4910 if Present (Enclosing_Subp)
4911 and then Nkind_In (Parent (C), N_Object_Declaration,
4912 N_Parameter_Specification)
4913 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
4914 then
4915 null;
4917 -- ... or the new declaration is in a package, and the visible
4918 -- declaration occurs outside that package.
4920 elsif Present (Enclosing_Pack)
4921 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
4922 then
4923 null;
4925 -- ... or the new declaration is a component declaration in a
4926 -- record type definition.
4928 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
4929 null;
4931 -- Don't issue error for non-source entities
4933 elsif Comes_From_Source (Def_Id)
4934 and then Comes_From_Source (C)
4935 then
4936 Error_Msg_Sloc := Sloc (C);
4937 Check_SPARK_Restriction
4938 ("redeclaration of identifier &#", Def_Id);
4939 end if;
4940 end;
4941 end if;
4943 -- Warn if new entity hides an old one
4945 if Warn_On_Hiding and then Present (C)
4947 -- Don't warn for record components since they always have a well
4948 -- defined scope which does not confuse other uses. Note that in
4949 -- some cases, Ekind has not been set yet.
4951 and then Ekind (C) /= E_Component
4952 and then Ekind (C) /= E_Discriminant
4953 and then Nkind (Parent (C)) /= N_Component_Declaration
4954 and then Ekind (Def_Id) /= E_Component
4955 and then Ekind (Def_Id) /= E_Discriminant
4956 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
4958 -- Don't warn for one character variables. It is too common to use
4959 -- such variables as locals and will just cause too many false hits.
4961 and then Length_Of_Name (Chars (C)) /= 1
4963 -- Don't warn for non-source entities
4965 and then Comes_From_Source (C)
4966 and then Comes_From_Source (Def_Id)
4968 -- Don't warn unless entity in question is in extended main source
4970 and then In_Extended_Main_Source_Unit (Def_Id)
4972 -- Finally, the hidden entity must be either immediately visible or
4973 -- use visible (i.e. from a used package).
4975 and then
4976 (Is_Immediately_Visible (C)
4977 or else
4978 Is_Potentially_Use_Visible (C))
4979 then
4980 Error_Msg_Sloc := Sloc (C);
4981 Error_Msg_N ("declaration hides &#?h?", Def_Id);
4982 end if;
4983 end Enter_Name;
4985 ---------------
4986 -- Entity_Of --
4987 ---------------
4989 function Entity_Of (N : Node_Id) return Entity_Id is
4990 Id : Entity_Id;
4992 begin
4993 Id := Empty;
4995 if Is_Entity_Name (N) then
4996 Id := Entity (N);
4998 -- Follow a possible chain of renamings to reach the root renamed
4999 -- object.
5001 while Present (Id) and then Present (Renamed_Object (Id)) loop
5002 if Is_Entity_Name (Renamed_Object (Id)) then
5003 Id := Entity (Renamed_Object (Id));
5004 else
5005 Id := Empty;
5006 exit;
5007 end if;
5008 end loop;
5009 end if;
5011 return Id;
5012 end Entity_Of;
5014 --------------------------
5015 -- Explain_Limited_Type --
5016 --------------------------
5018 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
5019 C : Entity_Id;
5021 begin
5022 -- For array, component type must be limited
5024 if Is_Array_Type (T) then
5025 Error_Msg_Node_2 := T;
5026 Error_Msg_NE
5027 ("\component type& of type& is limited", N, Component_Type (T));
5028 Explain_Limited_Type (Component_Type (T), N);
5030 elsif Is_Record_Type (T) then
5032 -- No need for extra messages if explicit limited record
5034 if Is_Limited_Record (Base_Type (T)) then
5035 return;
5036 end if;
5038 -- Otherwise find a limited component. Check only components that
5039 -- come from source, or inherited components that appear in the
5040 -- source of the ancestor.
5042 C := First_Component (T);
5043 while Present (C) loop
5044 if Is_Limited_Type (Etype (C))
5045 and then
5046 (Comes_From_Source (C)
5047 or else
5048 (Present (Original_Record_Component (C))
5049 and then
5050 Comes_From_Source (Original_Record_Component (C))))
5051 then
5052 Error_Msg_Node_2 := T;
5053 Error_Msg_NE ("\component& of type& has limited type", N, C);
5054 Explain_Limited_Type (Etype (C), N);
5055 return;
5056 end if;
5058 Next_Component (C);
5059 end loop;
5061 -- The type may be declared explicitly limited, even if no component
5062 -- of it is limited, in which case we fall out of the loop.
5063 return;
5064 end if;
5065 end Explain_Limited_Type;
5067 -----------------
5068 -- Find_Actual --
5069 -----------------
5071 procedure Find_Actual
5072 (N : Node_Id;
5073 Formal : out Entity_Id;
5074 Call : out Node_Id)
5076 Parnt : constant Node_Id := Parent (N);
5077 Actual : Node_Id;
5079 begin
5080 if (Nkind (Parnt) = N_Indexed_Component
5081 or else
5082 Nkind (Parnt) = N_Selected_Component)
5083 and then N = Prefix (Parnt)
5084 then
5085 Find_Actual (Parnt, Formal, Call);
5086 return;
5088 elsif Nkind (Parnt) = N_Parameter_Association
5089 and then N = Explicit_Actual_Parameter (Parnt)
5090 then
5091 Call := Parent (Parnt);
5093 elsif Nkind (Parnt) in N_Subprogram_Call then
5094 Call := Parnt;
5096 else
5097 Formal := Empty;
5098 Call := Empty;
5099 return;
5100 end if;
5102 -- If we have a call to a subprogram look for the parameter. Note that
5103 -- we exclude overloaded calls, since we don't know enough to be sure
5104 -- of giving the right answer in this case.
5106 if Is_Entity_Name (Name (Call))
5107 and then Present (Entity (Name (Call)))
5108 and then Is_Overloadable (Entity (Name (Call)))
5109 and then not Is_Overloaded (Name (Call))
5110 then
5111 -- Fall here if we are definitely a parameter
5113 Actual := First_Actual (Call);
5114 Formal := First_Formal (Entity (Name (Call)));
5115 while Present (Formal) and then Present (Actual) loop
5116 if Actual = N then
5117 return;
5118 else
5119 Actual := Next_Actual (Actual);
5120 Formal := Next_Formal (Formal);
5121 end if;
5122 end loop;
5123 end if;
5125 -- Fall through here if we did not find matching actual
5127 Formal := Empty;
5128 Call := Empty;
5129 end Find_Actual;
5131 ---------------------------
5132 -- Find_Body_Discriminal --
5133 ---------------------------
5135 function Find_Body_Discriminal
5136 (Spec_Discriminant : Entity_Id) return Entity_Id
5138 Tsk : Entity_Id;
5139 Disc : Entity_Id;
5141 begin
5142 -- If expansion is suppressed, then the scope can be the concurrent type
5143 -- itself rather than a corresponding concurrent record type.
5145 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
5146 Tsk := Scope (Spec_Discriminant);
5148 else
5149 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
5151 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
5152 end if;
5154 -- Find discriminant of original concurrent type, and use its current
5155 -- discriminal, which is the renaming within the task/protected body.
5157 Disc := First_Discriminant (Tsk);
5158 while Present (Disc) loop
5159 if Chars (Disc) = Chars (Spec_Discriminant) then
5160 return Discriminal (Disc);
5161 end if;
5163 Next_Discriminant (Disc);
5164 end loop;
5166 -- That loop should always succeed in finding a matching entry and
5167 -- returning. Fatal error if not.
5169 raise Program_Error;
5170 end Find_Body_Discriminal;
5172 -------------------------------------
5173 -- Find_Corresponding_Discriminant --
5174 -------------------------------------
5176 function Find_Corresponding_Discriminant
5177 (Id : Node_Id;
5178 Typ : Entity_Id) return Entity_Id
5180 Par_Disc : Entity_Id;
5181 Old_Disc : Entity_Id;
5182 New_Disc : Entity_Id;
5184 begin
5185 Par_Disc := Original_Record_Component (Original_Discriminant (Id));
5187 -- The original type may currently be private, and the discriminant
5188 -- only appear on its full view.
5190 if Is_Private_Type (Scope (Par_Disc))
5191 and then not Has_Discriminants (Scope (Par_Disc))
5192 and then Present (Full_View (Scope (Par_Disc)))
5193 then
5194 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
5195 else
5196 Old_Disc := First_Discriminant (Scope (Par_Disc));
5197 end if;
5199 if Is_Class_Wide_Type (Typ) then
5200 New_Disc := First_Discriminant (Root_Type (Typ));
5201 else
5202 New_Disc := First_Discriminant (Typ);
5203 end if;
5205 while Present (Old_Disc) and then Present (New_Disc) loop
5206 if Old_Disc = Par_Disc then
5207 return New_Disc;
5208 else
5209 Next_Discriminant (Old_Disc);
5210 Next_Discriminant (New_Disc);
5211 end if;
5212 end loop;
5214 -- Should always find it
5216 raise Program_Error;
5217 end Find_Corresponding_Discriminant;
5219 ------------------------------------
5220 -- Find_Loop_In_Conditional_Block --
5221 ------------------------------------
5223 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is
5224 Stmt : Node_Id;
5226 begin
5227 Stmt := N;
5229 if Nkind (Stmt) = N_If_Statement then
5230 Stmt := First (Then_Statements (Stmt));
5231 end if;
5233 pragma Assert (Nkind (Stmt) = N_Block_Statement);
5235 -- Inspect the statements of the conditional block. In general the loop
5236 -- should be the first statement in the statement sequence of the block,
5237 -- but the finalization machinery may have introduced extra object
5238 -- declarations.
5240 Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
5241 while Present (Stmt) loop
5242 if Nkind (Stmt) = N_Loop_Statement then
5243 return Stmt;
5244 end if;
5246 Next (Stmt);
5247 end loop;
5249 -- The expansion of attribute 'Loop_Entry produced a malformed block
5251 raise Program_Error;
5252 end Find_Loop_In_Conditional_Block;
5254 --------------------------
5255 -- Find_Overlaid_Entity --
5256 --------------------------
5258 procedure Find_Overlaid_Entity
5259 (N : Node_Id;
5260 Ent : out Entity_Id;
5261 Off : out Boolean)
5263 Expr : Node_Id;
5265 begin
5266 -- We are looking for one of the two following forms:
5268 -- for X'Address use Y'Address
5270 -- or
5272 -- Const : constant Address := expr;
5273 -- ...
5274 -- for X'Address use Const;
5276 -- In the second case, the expr is either Y'Address, or recursively a
5277 -- constant that eventually references Y'Address.
5279 Ent := Empty;
5280 Off := False;
5282 if Nkind (N) = N_Attribute_Definition_Clause
5283 and then Chars (N) = Name_Address
5284 then
5285 Expr := Expression (N);
5287 -- This loop checks the form of the expression for Y'Address,
5288 -- using recursion to deal with intermediate constants.
5290 loop
5291 -- Check for Y'Address
5293 if Nkind (Expr) = N_Attribute_Reference
5294 and then Attribute_Name (Expr) = Name_Address
5295 then
5296 Expr := Prefix (Expr);
5297 exit;
5299 -- Check for Const where Const is a constant entity
5301 elsif Is_Entity_Name (Expr)
5302 and then Ekind (Entity (Expr)) = E_Constant
5303 then
5304 Expr := Constant_Value (Entity (Expr));
5306 -- Anything else does not need checking
5308 else
5309 return;
5310 end if;
5311 end loop;
5313 -- This loop checks the form of the prefix for an entity, using
5314 -- recursion to deal with intermediate components.
5316 loop
5317 -- Check for Y where Y is an entity
5319 if Is_Entity_Name (Expr) then
5320 Ent := Entity (Expr);
5321 return;
5323 -- Check for components
5325 elsif
5326 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
5327 then
5328 Expr := Prefix (Expr);
5329 Off := True;
5331 -- Anything else does not need checking
5333 else
5334 return;
5335 end if;
5336 end loop;
5337 end if;
5338 end Find_Overlaid_Entity;
5340 -------------------------
5341 -- Find_Parameter_Type --
5342 -------------------------
5344 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
5345 begin
5346 if Nkind (Param) /= N_Parameter_Specification then
5347 return Empty;
5349 -- For an access parameter, obtain the type from the formal entity
5350 -- itself, because access to subprogram nodes do not carry a type.
5351 -- Shouldn't we always use the formal entity ???
5353 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
5354 return Etype (Defining_Identifier (Param));
5356 else
5357 return Etype (Parameter_Type (Param));
5358 end if;
5359 end Find_Parameter_Type;
5361 -----------------------------
5362 -- Find_Static_Alternative --
5363 -----------------------------
5365 function Find_Static_Alternative (N : Node_Id) return Node_Id is
5366 Expr : constant Node_Id := Expression (N);
5367 Val : constant Uint := Expr_Value (Expr);
5368 Alt : Node_Id;
5369 Choice : Node_Id;
5371 begin
5372 Alt := First (Alternatives (N));
5374 Search : loop
5375 if Nkind (Alt) /= N_Pragma then
5376 Choice := First (Discrete_Choices (Alt));
5377 while Present (Choice) loop
5379 -- Others choice, always matches
5381 if Nkind (Choice) = N_Others_Choice then
5382 exit Search;
5384 -- Range, check if value is in the range
5386 elsif Nkind (Choice) = N_Range then
5387 exit Search when
5388 Val >= Expr_Value (Low_Bound (Choice))
5389 and then
5390 Val <= Expr_Value (High_Bound (Choice));
5392 -- Choice is a subtype name. Note that we know it must
5393 -- be a static subtype, since otherwise it would have
5394 -- been diagnosed as illegal.
5396 elsif Is_Entity_Name (Choice)
5397 and then Is_Type (Entity (Choice))
5398 then
5399 exit Search when Is_In_Range (Expr, Etype (Choice),
5400 Assume_Valid => False);
5402 -- Choice is a subtype indication
5404 elsif Nkind (Choice) = N_Subtype_Indication then
5405 declare
5406 C : constant Node_Id := Constraint (Choice);
5407 R : constant Node_Id := Range_Expression (C);
5409 begin
5410 exit Search when
5411 Val >= Expr_Value (Low_Bound (R))
5412 and then
5413 Val <= Expr_Value (High_Bound (R));
5414 end;
5416 -- Choice is a simple expression
5418 else
5419 exit Search when Val = Expr_Value (Choice);
5420 end if;
5422 Next (Choice);
5423 end loop;
5424 end if;
5426 Next (Alt);
5427 pragma Assert (Present (Alt));
5428 end loop Search;
5430 -- The above loop *must* terminate by finding a match, since
5431 -- we know the case statement is valid, and the value of the
5432 -- expression is known at compile time. When we fall out of
5433 -- the loop, Alt points to the alternative that we know will
5434 -- be selected at run time.
5436 return Alt;
5437 end Find_Static_Alternative;
5439 ------------------
5440 -- First_Actual --
5441 ------------------
5443 function First_Actual (Node : Node_Id) return Node_Id is
5444 N : Node_Id;
5446 begin
5447 if No (Parameter_Associations (Node)) then
5448 return Empty;
5449 end if;
5451 N := First (Parameter_Associations (Node));
5453 if Nkind (N) = N_Parameter_Association then
5454 return First_Named_Actual (Node);
5455 else
5456 return N;
5457 end if;
5458 end First_Actual;
5460 -----------------------
5461 -- Gather_Components --
5462 -----------------------
5464 procedure Gather_Components
5465 (Typ : Entity_Id;
5466 Comp_List : Node_Id;
5467 Governed_By : List_Id;
5468 Into : Elist_Id;
5469 Report_Errors : out Boolean)
5471 Assoc : Node_Id;
5472 Variant : Node_Id;
5473 Discrete_Choice : Node_Id;
5474 Comp_Item : Node_Id;
5476 Discrim : Entity_Id;
5477 Discrim_Name : Node_Id;
5478 Discrim_Value : Node_Id;
5480 begin
5481 Report_Errors := False;
5483 if No (Comp_List) or else Null_Present (Comp_List) then
5484 return;
5486 elsif Present (Component_Items (Comp_List)) then
5487 Comp_Item := First (Component_Items (Comp_List));
5489 else
5490 Comp_Item := Empty;
5491 end if;
5493 while Present (Comp_Item) loop
5495 -- Skip the tag of a tagged record, the interface tags, as well
5496 -- as all items that are not user components (anonymous types,
5497 -- rep clauses, Parent field, controller field).
5499 if Nkind (Comp_Item) = N_Component_Declaration then
5500 declare
5501 Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
5502 begin
5503 if not Is_Tag (Comp)
5504 and then Chars (Comp) /= Name_uParent
5505 then
5506 Append_Elmt (Comp, Into);
5507 end if;
5508 end;
5509 end if;
5511 Next (Comp_Item);
5512 end loop;
5514 if No (Variant_Part (Comp_List)) then
5515 return;
5516 else
5517 Discrim_Name := Name (Variant_Part (Comp_List));
5518 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
5519 end if;
5521 -- Look for the discriminant that governs this variant part.
5522 -- The discriminant *must* be in the Governed_By List
5524 Assoc := First (Governed_By);
5525 Find_Constraint : loop
5526 Discrim := First (Choices (Assoc));
5527 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
5528 or else (Present (Corresponding_Discriminant (Entity (Discrim)))
5529 and then
5530 Chars (Corresponding_Discriminant (Entity (Discrim))) =
5531 Chars (Discrim_Name))
5532 or else Chars (Original_Record_Component (Entity (Discrim)))
5533 = Chars (Discrim_Name);
5535 if No (Next (Assoc)) then
5536 if not Is_Constrained (Typ)
5537 and then Is_Derived_Type (Typ)
5538 and then Present (Stored_Constraint (Typ))
5539 then
5540 -- If the type is a tagged type with inherited discriminants,
5541 -- use the stored constraint on the parent in order to find
5542 -- the values of discriminants that are otherwise hidden by an
5543 -- explicit constraint. Renamed discriminants are handled in
5544 -- the code above.
5546 -- If several parent discriminants are renamed by a single
5547 -- discriminant of the derived type, the call to obtain the
5548 -- Corresponding_Discriminant field only retrieves the last
5549 -- of them. We recover the constraint on the others from the
5550 -- Stored_Constraint as well.
5552 declare
5553 D : Entity_Id;
5554 C : Elmt_Id;
5556 begin
5557 D := First_Discriminant (Etype (Typ));
5558 C := First_Elmt (Stored_Constraint (Typ));
5559 while Present (D) and then Present (C) loop
5560 if Chars (Discrim_Name) = Chars (D) then
5561 if Is_Entity_Name (Node (C))
5562 and then Entity (Node (C)) = Entity (Discrim)
5563 then
5564 -- D is renamed by Discrim, whose value is given in
5565 -- Assoc.
5567 null;
5569 else
5570 Assoc :=
5571 Make_Component_Association (Sloc (Typ),
5572 New_List
5573 (New_Occurrence_Of (D, Sloc (Typ))),
5574 Duplicate_Subexpr_No_Checks (Node (C)));
5575 end if;
5576 exit Find_Constraint;
5577 end if;
5579 Next_Discriminant (D);
5580 Next_Elmt (C);
5581 end loop;
5582 end;
5583 end if;
5584 end if;
5586 if No (Next (Assoc)) then
5587 Error_Msg_NE (" missing value for discriminant&",
5588 First (Governed_By), Discrim_Name);
5589 Report_Errors := True;
5590 return;
5591 end if;
5593 Next (Assoc);
5594 end loop Find_Constraint;
5596 Discrim_Value := Expression (Assoc);
5598 if not Is_OK_Static_Expression (Discrim_Value) then
5599 Error_Msg_FE
5600 ("value for discriminant & must be static!",
5601 Discrim_Value, Discrim);
5602 Why_Not_Static (Discrim_Value);
5603 Report_Errors := True;
5604 return;
5605 end if;
5607 Search_For_Discriminant_Value : declare
5608 Low : Node_Id;
5609 High : Node_Id;
5611 UI_High : Uint;
5612 UI_Low : Uint;
5613 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
5615 begin
5616 Find_Discrete_Value : while Present (Variant) loop
5617 Discrete_Choice := First (Discrete_Choices (Variant));
5618 while Present (Discrete_Choice) loop
5619 exit Find_Discrete_Value when
5620 Nkind (Discrete_Choice) = N_Others_Choice;
5622 Get_Index_Bounds (Discrete_Choice, Low, High);
5624 UI_Low := Expr_Value (Low);
5625 UI_High := Expr_Value (High);
5627 exit Find_Discrete_Value when
5628 UI_Low <= UI_Discrim_Value
5629 and then
5630 UI_High >= UI_Discrim_Value;
5632 Next (Discrete_Choice);
5633 end loop;
5635 Next_Non_Pragma (Variant);
5636 end loop Find_Discrete_Value;
5637 end Search_For_Discriminant_Value;
5639 if No (Variant) then
5640 Error_Msg_NE
5641 ("value of discriminant & is out of range", Discrim_Value, Discrim);
5642 Report_Errors := True;
5643 return;
5644 end if;
5646 -- If we have found the corresponding choice, recursively add its
5647 -- components to the Into list.
5649 Gather_Components
5650 (Empty, Component_List (Variant), Governed_By, Into, Report_Errors);
5651 end Gather_Components;
5653 ------------------------
5654 -- Get_Actual_Subtype --
5655 ------------------------
5657 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
5658 Typ : constant Entity_Id := Etype (N);
5659 Utyp : Entity_Id := Underlying_Type (Typ);
5660 Decl : Node_Id;
5661 Atyp : Entity_Id;
5663 begin
5664 if No (Utyp) then
5665 Utyp := Typ;
5666 end if;
5668 -- If what we have is an identifier that references a subprogram
5669 -- formal, or a variable or constant object, then we get the actual
5670 -- subtype from the referenced entity if one has been built.
5672 if Nkind (N) = N_Identifier
5673 and then
5674 (Is_Formal (Entity (N))
5675 or else Ekind (Entity (N)) = E_Constant
5676 or else Ekind (Entity (N)) = E_Variable)
5677 and then Present (Actual_Subtype (Entity (N)))
5678 then
5679 return Actual_Subtype (Entity (N));
5681 -- Actual subtype of unchecked union is always itself. We never need
5682 -- the "real" actual subtype. If we did, we couldn't get it anyway
5683 -- because the discriminant is not available. The restrictions on
5684 -- Unchecked_Union are designed to make sure that this is OK.
5686 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
5687 return Typ;
5689 -- Here for the unconstrained case, we must find actual subtype
5690 -- No actual subtype is available, so we must build it on the fly.
5692 -- Checking the type, not the underlying type, for constrainedness
5693 -- seems to be necessary. Maybe all the tests should be on the type???
5695 elsif (not Is_Constrained (Typ))
5696 and then (Is_Array_Type (Utyp)
5697 or else (Is_Record_Type (Utyp)
5698 and then Has_Discriminants (Utyp)))
5699 and then not Has_Unknown_Discriminants (Utyp)
5700 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
5701 then
5702 -- Nothing to do if in spec expression (why not???)
5704 if In_Spec_Expression then
5705 return Typ;
5707 elsif Is_Private_Type (Typ)
5708 and then not Has_Discriminants (Typ)
5709 then
5710 -- If the type has no discriminants, there is no subtype to
5711 -- build, even if the underlying type is discriminated.
5713 return Typ;
5715 -- Else build the actual subtype
5717 else
5718 Decl := Build_Actual_Subtype (Typ, N);
5719 Atyp := Defining_Identifier (Decl);
5721 -- If Build_Actual_Subtype generated a new declaration then use it
5723 if Atyp /= Typ then
5725 -- The actual subtype is an Itype, so analyze the declaration,
5726 -- but do not attach it to the tree, to get the type defined.
5728 Set_Parent (Decl, N);
5729 Set_Is_Itype (Atyp);
5730 Analyze (Decl, Suppress => All_Checks);
5731 Set_Associated_Node_For_Itype (Atyp, N);
5732 Set_Has_Delayed_Freeze (Atyp, False);
5734 -- We need to freeze the actual subtype immediately. This is
5735 -- needed, because otherwise this Itype will not get frozen
5736 -- at all, and it is always safe to freeze on creation because
5737 -- any associated types must be frozen at this point.
5739 Freeze_Itype (Atyp, N);
5740 return Atyp;
5742 -- Otherwise we did not build a declaration, so return original
5744 else
5745 return Typ;
5746 end if;
5747 end if;
5749 -- For all remaining cases, the actual subtype is the same as
5750 -- the nominal type.
5752 else
5753 return Typ;
5754 end if;
5755 end Get_Actual_Subtype;
5757 -------------------------------------
5758 -- Get_Actual_Subtype_If_Available --
5759 -------------------------------------
5761 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
5762 Typ : constant Entity_Id := Etype (N);
5764 begin
5765 -- If what we have is an identifier that references a subprogram
5766 -- formal, or a variable or constant object, then we get the actual
5767 -- subtype from the referenced entity if one has been built.
5769 if Nkind (N) = N_Identifier
5770 and then
5771 (Is_Formal (Entity (N))
5772 or else Ekind (Entity (N)) = E_Constant
5773 or else Ekind (Entity (N)) = E_Variable)
5774 and then Present (Actual_Subtype (Entity (N)))
5775 then
5776 return Actual_Subtype (Entity (N));
5778 -- Otherwise the Etype of N is returned unchanged
5780 else
5781 return Typ;
5782 end if;
5783 end Get_Actual_Subtype_If_Available;
5785 ------------------------
5786 -- Get_Body_From_Stub --
5787 ------------------------
5789 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
5790 begin
5791 return Proper_Body (Unit (Library_Unit (N)));
5792 end Get_Body_From_Stub;
5794 -------------------------------
5795 -- Get_Default_External_Name --
5796 -------------------------------
5798 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
5799 begin
5800 Get_Decoded_Name_String (Chars (E));
5802 if Opt.External_Name_Imp_Casing = Uppercase then
5803 Set_Casing (All_Upper_Case);
5804 else
5805 Set_Casing (All_Lower_Case);
5806 end if;
5808 return
5809 Make_String_Literal (Sloc (E),
5810 Strval => String_From_Name_Buffer);
5811 end Get_Default_External_Name;
5813 --------------------------
5814 -- Get_Enclosing_Object --
5815 --------------------------
5817 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
5818 begin
5819 if Is_Entity_Name (N) then
5820 return Entity (N);
5821 else
5822 case Nkind (N) is
5823 when N_Indexed_Component |
5824 N_Slice |
5825 N_Selected_Component =>
5827 -- If not generating code, a dereference may be left implicit.
5828 -- In thoses cases, return Empty.
5830 if Is_Access_Type (Etype (Prefix (N))) then
5831 return Empty;
5832 else
5833 return Get_Enclosing_Object (Prefix (N));
5834 end if;
5836 when N_Type_Conversion =>
5837 return Get_Enclosing_Object (Expression (N));
5839 when others =>
5840 return Empty;
5841 end case;
5842 end if;
5843 end Get_Enclosing_Object;
5845 ---------------------------
5846 -- Get_Enum_Lit_From_Pos --
5847 ---------------------------
5849 function Get_Enum_Lit_From_Pos
5850 (T : Entity_Id;
5851 Pos : Uint;
5852 Loc : Source_Ptr) return Node_Id
5854 Btyp : Entity_Id := Base_Type (T);
5855 Lit : Node_Id;
5857 begin
5858 -- In the case where the literal is of type Character, Wide_Character
5859 -- or Wide_Wide_Character or of a type derived from them, there needs
5860 -- to be some special handling since there is no explicit chain of
5861 -- literals to search. Instead, an N_Character_Literal node is created
5862 -- with the appropriate Char_Code and Chars fields.
5864 if Is_Standard_Character_Type (T) then
5865 Set_Character_Literal_Name (UI_To_CC (Pos));
5866 return
5867 Make_Character_Literal (Loc,
5868 Chars => Name_Find,
5869 Char_Literal_Value => Pos);
5871 -- For all other cases, we have a complete table of literals, and
5872 -- we simply iterate through the chain of literal until the one
5873 -- with the desired position value is found.
5876 else
5877 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
5878 Btyp := Full_View (Btyp);
5879 end if;
5881 Lit := First_Literal (Btyp);
5882 for J in 1 .. UI_To_Int (Pos) loop
5883 Next_Literal (Lit);
5884 end loop;
5886 return New_Occurrence_Of (Lit, Loc);
5887 end if;
5888 end Get_Enum_Lit_From_Pos;
5890 ---------------------------------
5891 -- Get_Ensures_From_CTC_Pragma --
5892 ---------------------------------
5894 function Get_Ensures_From_CTC_Pragma (N : Node_Id) return Node_Id is
5895 Args : constant List_Id := Pragma_Argument_Associations (N);
5896 Res : Node_Id;
5898 begin
5899 if List_Length (Args) = 4 then
5900 Res := Pick (Args, 4);
5902 elsif List_Length (Args) = 3 then
5903 Res := Pick (Args, 3);
5905 if Chars (Res) /= Name_Ensures then
5906 Res := Empty;
5907 end if;
5909 else
5910 Res := Empty;
5911 end if;
5913 return Res;
5914 end Get_Ensures_From_CTC_Pragma;
5916 ------------------------
5917 -- Get_Generic_Entity --
5918 ------------------------
5920 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
5921 Ent : constant Entity_Id := Entity (Name (N));
5922 begin
5923 if Present (Renamed_Object (Ent)) then
5924 return Renamed_Object (Ent);
5925 else
5926 return Ent;
5927 end if;
5928 end Get_Generic_Entity;
5930 -------------------------------------
5931 -- Get_Incomplete_View_Of_Ancestor --
5932 -------------------------------------
5934 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
5935 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
5936 Par_Scope : Entity_Id;
5937 Par_Type : Entity_Id;
5939 begin
5940 -- The incomplete view of an ancestor is only relevant for private
5941 -- derived types in child units.
5943 if not Is_Derived_Type (E)
5944 or else not Is_Child_Unit (Cur_Unit)
5945 then
5946 return Empty;
5948 else
5949 Par_Scope := Scope (Cur_Unit);
5950 if No (Par_Scope) then
5951 return Empty;
5952 end if;
5954 Par_Type := Etype (Base_Type (E));
5956 -- Traverse list of ancestor types until we find one declared in
5957 -- a parent or grandparent unit (two levels seem sufficient).
5959 while Present (Par_Type) loop
5960 if Scope (Par_Type) = Par_Scope
5961 or else Scope (Par_Type) = Scope (Par_Scope)
5962 then
5963 return Par_Type;
5965 elsif not Is_Derived_Type (Par_Type) then
5966 return Empty;
5968 else
5969 Par_Type := Etype (Base_Type (Par_Type));
5970 end if;
5971 end loop;
5973 -- If none found, there is no relevant ancestor type.
5975 return Empty;
5976 end if;
5977 end Get_Incomplete_View_Of_Ancestor;
5979 ----------------------
5980 -- Get_Index_Bounds --
5981 ----------------------
5983 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
5984 Kind : constant Node_Kind := Nkind (N);
5985 R : Node_Id;
5987 begin
5988 if Kind = N_Range then
5989 L := Low_Bound (N);
5990 H := High_Bound (N);
5992 elsif Kind = N_Subtype_Indication then
5993 R := Range_Expression (Constraint (N));
5995 if R = Error then
5996 L := Error;
5997 H := Error;
5998 return;
6000 else
6001 L := Low_Bound (Range_Expression (Constraint (N)));
6002 H := High_Bound (Range_Expression (Constraint (N)));
6003 end if;
6005 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
6006 if Error_Posted (Scalar_Range (Entity (N))) then
6007 L := Error;
6008 H := Error;
6010 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
6011 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
6013 else
6014 L := Low_Bound (Scalar_Range (Entity (N)));
6015 H := High_Bound (Scalar_Range (Entity (N)));
6016 end if;
6018 else
6019 -- N is an expression, indicating a range with one value
6021 L := N;
6022 H := N;
6023 end if;
6024 end Get_Index_Bounds;
6026 ----------------------------------
6027 -- Get_Library_Unit_Name_string --
6028 ----------------------------------
6030 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
6031 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
6033 begin
6034 Get_Unit_Name_String (Unit_Name_Id);
6036 -- Remove seven last character (" (spec)" or " (body)")
6038 Name_Len := Name_Len - 7;
6039 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
6040 end Get_Library_Unit_Name_String;
6042 ------------------------
6043 -- Get_Name_Entity_Id --
6044 ------------------------
6046 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
6047 begin
6048 return Entity_Id (Get_Name_Table_Info (Id));
6049 end Get_Name_Entity_Id;
6051 ------------------------------
6052 -- Get_Name_From_CTC_Pragma --
6053 ------------------------------
6055 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
6056 Arg : constant Node_Id :=
6057 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
6058 begin
6059 return Strval (Expr_Value_S (Arg));
6060 end Get_Name_From_CTC_Pragma;
6062 -------------------
6063 -- Get_Pragma_Id --
6064 -------------------
6066 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
6067 begin
6068 return Get_Pragma_Id (Pragma_Name (N));
6069 end Get_Pragma_Id;
6071 ---------------------------
6072 -- Get_Referenced_Object --
6073 ---------------------------
6075 function Get_Referenced_Object (N : Node_Id) return Node_Id is
6076 R : Node_Id;
6078 begin
6079 R := N;
6080 while Is_Entity_Name (R)
6081 and then Present (Renamed_Object (Entity (R)))
6082 loop
6083 R := Renamed_Object (Entity (R));
6084 end loop;
6086 return R;
6087 end Get_Referenced_Object;
6089 ------------------------
6090 -- Get_Renamed_Entity --
6091 ------------------------
6093 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
6094 R : Entity_Id;
6096 begin
6097 R := E;
6098 while Present (Renamed_Entity (R)) loop
6099 R := Renamed_Entity (R);
6100 end loop;
6102 return R;
6103 end Get_Renamed_Entity;
6105 ----------------------------------
6106 -- Get_Requires_From_CTC_Pragma --
6107 ----------------------------------
6109 function Get_Requires_From_CTC_Pragma (N : Node_Id) return Node_Id is
6110 Args : constant List_Id := Pragma_Argument_Associations (N);
6111 Res : Node_Id;
6113 begin
6114 if List_Length (Args) >= 3 then
6115 Res := Pick (Args, 3);
6117 if Chars (Res) /= Name_Requires then
6118 Res := Empty;
6119 end if;
6121 else
6122 Res := Empty;
6123 end if;
6125 return Res;
6126 end Get_Requires_From_CTC_Pragma;
6128 -------------------------
6129 -- Get_Subprogram_Body --
6130 -------------------------
6132 function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
6133 Decl : Node_Id;
6135 begin
6136 Decl := Unit_Declaration_Node (E);
6138 if Nkind (Decl) = N_Subprogram_Body then
6139 return Decl;
6141 -- The below comment is bad, because it is possible for
6142 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
6144 else -- Nkind (Decl) = N_Subprogram_Declaration
6146 if Present (Corresponding_Body (Decl)) then
6147 return Unit_Declaration_Node (Corresponding_Body (Decl));
6149 -- Imported subprogram case
6151 else
6152 return Empty;
6153 end if;
6154 end if;
6155 end Get_Subprogram_Body;
6157 ---------------------------
6158 -- Get_Subprogram_Entity --
6159 ---------------------------
6161 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
6162 Subp : Node_Id;
6163 Subp_Id : Entity_Id;
6165 begin
6166 if Nkind (Nod) = N_Accept_Statement then
6167 Subp := Entry_Direct_Name (Nod);
6169 elsif Nkind (Nod) = N_Slice then
6170 Subp := Prefix (Nod);
6172 else
6173 Subp := Name (Nod);
6174 end if;
6176 -- Strip the subprogram call
6178 loop
6179 if Nkind_In (Subp, N_Explicit_Dereference,
6180 N_Indexed_Component,
6181 N_Selected_Component)
6182 then
6183 Subp := Prefix (Subp);
6185 elsif Nkind_In (Subp, N_Type_Conversion,
6186 N_Unchecked_Type_Conversion)
6187 then
6188 Subp := Expression (Subp);
6190 else
6191 exit;
6192 end if;
6193 end loop;
6195 -- Extract the entity of the subprogram call
6197 if Is_Entity_Name (Subp) then
6198 Subp_Id := Entity (Subp);
6200 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
6201 Subp_Id := Directly_Designated_Type (Subp_Id);
6202 end if;
6204 if Is_Subprogram (Subp_Id) then
6205 return Subp_Id;
6206 else
6207 return Empty;
6208 end if;
6210 -- The search did not find a construct that denotes a subprogram
6212 else
6213 return Empty;
6214 end if;
6215 end Get_Subprogram_Entity;
6217 -----------------------------
6218 -- Get_Task_Body_Procedure --
6219 -----------------------------
6221 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
6222 begin
6223 -- Note: A task type may be the completion of a private type with
6224 -- discriminants. When performing elaboration checks on a task
6225 -- declaration, the current view of the type may be the private one,
6226 -- and the procedure that holds the body of the task is held in its
6227 -- underlying type.
6229 -- This is an odd function, why not have Task_Body_Procedure do
6230 -- the following digging???
6232 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
6233 end Get_Task_Body_Procedure;
6235 -----------------------
6236 -- Has_Access_Values --
6237 -----------------------
6239 function Has_Access_Values (T : Entity_Id) return Boolean is
6240 Typ : constant Entity_Id := Underlying_Type (T);
6242 begin
6243 -- Case of a private type which is not completed yet. This can only
6244 -- happen in the case of a generic format type appearing directly, or
6245 -- as a component of the type to which this function is being applied
6246 -- at the top level. Return False in this case, since we certainly do
6247 -- not know that the type contains access types.
6249 if No (Typ) then
6250 return False;
6252 elsif Is_Access_Type (Typ) then
6253 return True;
6255 elsif Is_Array_Type (Typ) then
6256 return Has_Access_Values (Component_Type (Typ));
6258 elsif Is_Record_Type (Typ) then
6259 declare
6260 Comp : Entity_Id;
6262 begin
6263 -- Loop to Check components
6265 Comp := First_Component_Or_Discriminant (Typ);
6266 while Present (Comp) loop
6268 -- Check for access component, tag field does not count, even
6269 -- though it is implemented internally using an access type.
6271 if Has_Access_Values (Etype (Comp))
6272 and then Chars (Comp) /= Name_uTag
6273 then
6274 return True;
6275 end if;
6277 Next_Component_Or_Discriminant (Comp);
6278 end loop;
6279 end;
6281 return False;
6283 else
6284 return False;
6285 end if;
6286 end Has_Access_Values;
6288 ------------------------------
6289 -- Has_Compatible_Alignment --
6290 ------------------------------
6292 function Has_Compatible_Alignment
6293 (Obj : Entity_Id;
6294 Expr : Node_Id) return Alignment_Result
6296 function Has_Compatible_Alignment_Internal
6297 (Obj : Entity_Id;
6298 Expr : Node_Id;
6299 Default : Alignment_Result) return Alignment_Result;
6300 -- This is the internal recursive function that actually does the work.
6301 -- There is one additional parameter, which says what the result should
6302 -- be if no alignment information is found, and there is no definite
6303 -- indication of compatible alignments. At the outer level, this is set
6304 -- to Unknown, but for internal recursive calls in the case where types
6305 -- are known to be correct, it is set to Known_Compatible.
6307 ---------------------------------------
6308 -- Has_Compatible_Alignment_Internal --
6309 ---------------------------------------
6311 function Has_Compatible_Alignment_Internal
6312 (Obj : Entity_Id;
6313 Expr : Node_Id;
6314 Default : Alignment_Result) return Alignment_Result
6316 Result : Alignment_Result := Known_Compatible;
6317 -- Holds the current status of the result. Note that once a value of
6318 -- Known_Incompatible is set, it is sticky and does not get changed
6319 -- to Unknown (the value in Result only gets worse as we go along,
6320 -- never better).
6322 Offs : Uint := No_Uint;
6323 -- Set to a factor of the offset from the base object when Expr is a
6324 -- selected or indexed component, based on Component_Bit_Offset and
6325 -- Component_Size respectively. A negative value is used to represent
6326 -- a value which is not known at compile time.
6328 procedure Check_Prefix;
6329 -- Checks the prefix recursively in the case where the expression
6330 -- is an indexed or selected component.
6332 procedure Set_Result (R : Alignment_Result);
6333 -- If R represents a worse outcome (unknown instead of known
6334 -- compatible, or known incompatible), then set Result to R.
6336 ------------------
6337 -- Check_Prefix --
6338 ------------------
6340 procedure Check_Prefix is
6341 begin
6342 -- The subtlety here is that in doing a recursive call to check
6343 -- the prefix, we have to decide what to do in the case where we
6344 -- don't find any specific indication of an alignment problem.
6346 -- At the outer level, we normally set Unknown as the result in
6347 -- this case, since we can only set Known_Compatible if we really
6348 -- know that the alignment value is OK, but for the recursive
6349 -- call, in the case where the types match, and we have not
6350 -- specified a peculiar alignment for the object, we are only
6351 -- concerned about suspicious rep clauses, the default case does
6352 -- not affect us, since the compiler will, in the absence of such
6353 -- rep clauses, ensure that the alignment is correct.
6355 if Default = Known_Compatible
6356 or else
6357 (Etype (Obj) = Etype (Expr)
6358 and then (Unknown_Alignment (Obj)
6359 or else
6360 Alignment (Obj) = Alignment (Etype (Obj))))
6361 then
6362 Set_Result
6363 (Has_Compatible_Alignment_Internal
6364 (Obj, Prefix (Expr), Known_Compatible));
6366 -- In all other cases, we need a full check on the prefix
6368 else
6369 Set_Result
6370 (Has_Compatible_Alignment_Internal
6371 (Obj, Prefix (Expr), Unknown));
6372 end if;
6373 end Check_Prefix;
6375 ----------------
6376 -- Set_Result --
6377 ----------------
6379 procedure Set_Result (R : Alignment_Result) is
6380 begin
6381 if R > Result then
6382 Result := R;
6383 end if;
6384 end Set_Result;
6386 -- Start of processing for Has_Compatible_Alignment_Internal
6388 begin
6389 -- If Expr is a selected component, we must make sure there is no
6390 -- potentially troublesome component clause, and that the record is
6391 -- not packed.
6393 if Nkind (Expr) = N_Selected_Component then
6395 -- Packed record always generate unknown alignment
6397 if Is_Packed (Etype (Prefix (Expr))) then
6398 Set_Result (Unknown);
6399 end if;
6401 -- Check prefix and component offset
6403 Check_Prefix;
6404 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
6406 -- If Expr is an indexed component, we must make sure there is no
6407 -- potentially troublesome Component_Size clause and that the array
6408 -- is not bit-packed.
6410 elsif Nkind (Expr) = N_Indexed_Component then
6411 declare
6412 Typ : constant Entity_Id := Etype (Prefix (Expr));
6413 Ind : constant Node_Id := First_Index (Typ);
6415 begin
6416 -- Bit packed array always generates unknown alignment
6418 if Is_Bit_Packed_Array (Typ) then
6419 Set_Result (Unknown);
6420 end if;
6422 -- Check prefix and component offset
6424 Check_Prefix;
6425 Offs := Component_Size (Typ);
6427 -- Small optimization: compute the full offset when possible
6429 if Offs /= No_Uint
6430 and then Offs > Uint_0
6431 and then Present (Ind)
6432 and then Nkind (Ind) = N_Range
6433 and then Compile_Time_Known_Value (Low_Bound (Ind))
6434 and then Compile_Time_Known_Value (First (Expressions (Expr)))
6435 then
6436 Offs := Offs * (Expr_Value (First (Expressions (Expr)))
6437 - Expr_Value (Low_Bound ((Ind))));
6438 end if;
6439 end;
6440 end if;
6442 -- If we have a null offset, the result is entirely determined by
6443 -- the base object and has already been computed recursively.
6445 if Offs = Uint_0 then
6446 null;
6448 -- Case where we know the alignment of the object
6450 elsif Known_Alignment (Obj) then
6451 declare
6452 ObjA : constant Uint := Alignment (Obj);
6453 ExpA : Uint := No_Uint;
6454 SizA : Uint := No_Uint;
6456 begin
6457 -- If alignment of Obj is 1, then we are always OK
6459 if ObjA = 1 then
6460 Set_Result (Known_Compatible);
6462 -- Alignment of Obj is greater than 1, so we need to check
6464 else
6465 -- If we have an offset, see if it is compatible
6467 if Offs /= No_Uint and Offs > Uint_0 then
6468 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
6469 Set_Result (Known_Incompatible);
6470 end if;
6472 -- See if Expr is an object with known alignment
6474 elsif Is_Entity_Name (Expr)
6475 and then Known_Alignment (Entity (Expr))
6476 then
6477 ExpA := Alignment (Entity (Expr));
6479 -- Otherwise, we can use the alignment of the type of
6480 -- Expr given that we already checked for
6481 -- discombobulating rep clauses for the cases of indexed
6482 -- and selected components above.
6484 elsif Known_Alignment (Etype (Expr)) then
6485 ExpA := Alignment (Etype (Expr));
6487 -- Otherwise the alignment is unknown
6489 else
6490 Set_Result (Default);
6491 end if;
6493 -- If we got an alignment, see if it is acceptable
6495 if ExpA /= No_Uint and then ExpA < ObjA then
6496 Set_Result (Known_Incompatible);
6497 end if;
6499 -- If Expr is not a piece of a larger object, see if size
6500 -- is given. If so, check that it is not too small for the
6501 -- required alignment.
6503 if Offs /= No_Uint then
6504 null;
6506 -- See if Expr is an object with known size
6508 elsif Is_Entity_Name (Expr)
6509 and then Known_Static_Esize (Entity (Expr))
6510 then
6511 SizA := Esize (Entity (Expr));
6513 -- Otherwise, we check the object size of the Expr type
6515 elsif Known_Static_Esize (Etype (Expr)) then
6516 SizA := Esize (Etype (Expr));
6517 end if;
6519 -- If we got a size, see if it is a multiple of the Obj
6520 -- alignment, if not, then the alignment cannot be
6521 -- acceptable, since the size is always a multiple of the
6522 -- alignment.
6524 if SizA /= No_Uint then
6525 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
6526 Set_Result (Known_Incompatible);
6527 end if;
6528 end if;
6529 end if;
6530 end;
6532 -- If we do not know required alignment, any non-zero offset is a
6533 -- potential problem (but certainly may be OK, so result is unknown).
6535 elsif Offs /= No_Uint then
6536 Set_Result (Unknown);
6538 -- If we can't find the result by direct comparison of alignment
6539 -- values, then there is still one case that we can determine known
6540 -- result, and that is when we can determine that the types are the
6541 -- same, and no alignments are specified. Then we known that the
6542 -- alignments are compatible, even if we don't know the alignment
6543 -- value in the front end.
6545 elsif Etype (Obj) = Etype (Expr) then
6547 -- Types are the same, but we have to check for possible size
6548 -- and alignments on the Expr object that may make the alignment
6549 -- different, even though the types are the same.
6551 if Is_Entity_Name (Expr) then
6553 -- First check alignment of the Expr object. Any alignment less
6554 -- than Maximum_Alignment is worrisome since this is the case
6555 -- where we do not know the alignment of Obj.
6557 if Known_Alignment (Entity (Expr))
6558 and then
6559 UI_To_Int (Alignment (Entity (Expr))) <
6560 Ttypes.Maximum_Alignment
6561 then
6562 Set_Result (Unknown);
6564 -- Now check size of Expr object. Any size that is not an
6565 -- even multiple of Maximum_Alignment is also worrisome
6566 -- since it may cause the alignment of the object to be less
6567 -- than the alignment of the type.
6569 elsif Known_Static_Esize (Entity (Expr))
6570 and then
6571 (UI_To_Int (Esize (Entity (Expr))) mod
6572 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
6573 /= 0
6574 then
6575 Set_Result (Unknown);
6577 -- Otherwise same type is decisive
6579 else
6580 Set_Result (Known_Compatible);
6581 end if;
6582 end if;
6584 -- Another case to deal with is when there is an explicit size or
6585 -- alignment clause when the types are not the same. If so, then the
6586 -- result is Unknown. We don't need to do this test if the Default is
6587 -- Unknown, since that result will be set in any case.
6589 elsif Default /= Unknown
6590 and then (Has_Size_Clause (Etype (Expr))
6591 or else
6592 Has_Alignment_Clause (Etype (Expr)))
6593 then
6594 Set_Result (Unknown);
6596 -- If no indication found, set default
6598 else
6599 Set_Result (Default);
6600 end if;
6602 -- Return worst result found
6604 return Result;
6605 end Has_Compatible_Alignment_Internal;
6607 -- Start of processing for Has_Compatible_Alignment
6609 begin
6610 -- If Obj has no specified alignment, then set alignment from the type
6611 -- alignment. Perhaps we should always do this, but for sure we should
6612 -- do it when there is an address clause since we can do more if the
6613 -- alignment is known.
6615 if Unknown_Alignment (Obj) then
6616 Set_Alignment (Obj, Alignment (Etype (Obj)));
6617 end if;
6619 -- Now do the internal call that does all the work
6621 return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
6622 end Has_Compatible_Alignment;
6624 ----------------------
6625 -- Has_Declarations --
6626 ----------------------
6628 function Has_Declarations (N : Node_Id) return Boolean is
6629 begin
6630 return Nkind_In (Nkind (N), N_Accept_Statement,
6631 N_Block_Statement,
6632 N_Compilation_Unit_Aux,
6633 N_Entry_Body,
6634 N_Package_Body,
6635 N_Protected_Body,
6636 N_Subprogram_Body,
6637 N_Task_Body,
6638 N_Package_Specification);
6639 end Has_Declarations;
6641 -------------------
6642 -- Has_Denormals --
6643 -------------------
6645 function Has_Denormals (E : Entity_Id) return Boolean is
6646 begin
6647 return Is_Floating_Point_Type (E)
6648 and then Denorm_On_Target
6649 and then not Vax_Float (E);
6650 end Has_Denormals;
6652 -------------------------------------------
6653 -- Has_Discriminant_Dependent_Constraint --
6654 -------------------------------------------
6656 function Has_Discriminant_Dependent_Constraint
6657 (Comp : Entity_Id) return Boolean
6659 Comp_Decl : constant Node_Id := Parent (Comp);
6660 Subt_Indic : constant Node_Id :=
6661 Subtype_Indication (Component_Definition (Comp_Decl));
6662 Constr : Node_Id;
6663 Assn : Node_Id;
6665 begin
6666 if Nkind (Subt_Indic) = N_Subtype_Indication then
6667 Constr := Constraint (Subt_Indic);
6669 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
6670 Assn := First (Constraints (Constr));
6671 while Present (Assn) loop
6672 case Nkind (Assn) is
6673 when N_Subtype_Indication |
6674 N_Range |
6675 N_Identifier
6677 if Depends_On_Discriminant (Assn) then
6678 return True;
6679 end if;
6681 when N_Discriminant_Association =>
6682 if Depends_On_Discriminant (Expression (Assn)) then
6683 return True;
6684 end if;
6686 when others =>
6687 null;
6689 end case;
6691 Next (Assn);
6692 end loop;
6693 end if;
6694 end if;
6696 return False;
6697 end Has_Discriminant_Dependent_Constraint;
6699 --------------------
6700 -- Has_Infinities --
6701 --------------------
6703 function Has_Infinities (E : Entity_Id) return Boolean is
6704 begin
6705 return
6706 Is_Floating_Point_Type (E)
6707 and then Nkind (Scalar_Range (E)) = N_Range
6708 and then Includes_Infinities (Scalar_Range (E));
6709 end Has_Infinities;
6711 --------------------
6712 -- Has_Interfaces --
6713 --------------------
6715 function Has_Interfaces
6716 (T : Entity_Id;
6717 Use_Full_View : Boolean := True) return Boolean
6719 Typ : Entity_Id := Base_Type (T);
6721 begin
6722 -- Handle concurrent types
6724 if Is_Concurrent_Type (Typ) then
6725 Typ := Corresponding_Record_Type (Typ);
6726 end if;
6728 if not Present (Typ)
6729 or else not Is_Record_Type (Typ)
6730 or else not Is_Tagged_Type (Typ)
6731 then
6732 return False;
6733 end if;
6735 -- Handle private types
6737 if Use_Full_View
6738 and then Present (Full_View (Typ))
6739 then
6740 Typ := Full_View (Typ);
6741 end if;
6743 -- Handle concurrent record types
6745 if Is_Concurrent_Record_Type (Typ)
6746 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
6747 then
6748 return True;
6749 end if;
6751 loop
6752 if Is_Interface (Typ)
6753 or else
6754 (Is_Record_Type (Typ)
6755 and then Present (Interfaces (Typ))
6756 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
6757 then
6758 return True;
6759 end if;
6761 exit when Etype (Typ) = Typ
6763 -- Handle private types
6765 or else (Present (Full_View (Etype (Typ)))
6766 and then Full_View (Etype (Typ)) = Typ)
6768 -- Protect the frontend against wrong source with cyclic
6769 -- derivations
6771 or else Etype (Typ) = T;
6773 -- Climb to the ancestor type handling private types
6775 if Present (Full_View (Etype (Typ))) then
6776 Typ := Full_View (Etype (Typ));
6777 else
6778 Typ := Etype (Typ);
6779 end if;
6780 end loop;
6782 return False;
6783 end Has_Interfaces;
6785 ---------------------------------
6786 -- Has_No_Obvious_Side_Effects --
6787 ---------------------------------
6789 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
6790 begin
6791 -- For now, just handle literals, constants, and non-volatile
6792 -- variables and expressions combining these with operators or
6793 -- short circuit forms.
6795 if Nkind (N) in N_Numeric_Or_String_Literal then
6796 return True;
6798 elsif Nkind (N) = N_Character_Literal then
6799 return True;
6801 elsif Nkind (N) in N_Unary_Op then
6802 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
6804 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
6805 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
6806 and then
6807 Has_No_Obvious_Side_Effects (Right_Opnd (N));
6809 elsif Nkind (N) = N_Expression_With_Actions
6810 and then
6811 Is_Empty_List (Actions (N))
6812 then
6813 return Has_No_Obvious_Side_Effects (Expression (N));
6815 elsif Nkind (N) in N_Has_Entity then
6816 return Present (Entity (N))
6817 and then Ekind_In (Entity (N), E_Variable,
6818 E_Constant,
6819 E_Enumeration_Literal,
6820 E_In_Parameter,
6821 E_Out_Parameter,
6822 E_In_Out_Parameter)
6823 and then not Is_Volatile (Entity (N));
6825 else
6826 return False;
6827 end if;
6828 end Has_No_Obvious_Side_Effects;
6830 ------------------------
6831 -- Has_Null_Exclusion --
6832 ------------------------
6834 function Has_Null_Exclusion (N : Node_Id) return Boolean is
6835 begin
6836 case Nkind (N) is
6837 when N_Access_Definition |
6838 N_Access_Function_Definition |
6839 N_Access_Procedure_Definition |
6840 N_Access_To_Object_Definition |
6841 N_Allocator |
6842 N_Derived_Type_Definition |
6843 N_Function_Specification |
6844 N_Subtype_Declaration =>
6845 return Null_Exclusion_Present (N);
6847 when N_Component_Definition |
6848 N_Formal_Object_Declaration |
6849 N_Object_Renaming_Declaration =>
6850 if Present (Subtype_Mark (N)) then
6851 return Null_Exclusion_Present (N);
6852 else pragma Assert (Present (Access_Definition (N)));
6853 return Null_Exclusion_Present (Access_Definition (N));
6854 end if;
6856 when N_Discriminant_Specification =>
6857 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
6858 return Null_Exclusion_Present (Discriminant_Type (N));
6859 else
6860 return Null_Exclusion_Present (N);
6861 end if;
6863 when N_Object_Declaration =>
6864 if Nkind (Object_Definition (N)) = N_Access_Definition then
6865 return Null_Exclusion_Present (Object_Definition (N));
6866 else
6867 return Null_Exclusion_Present (N);
6868 end if;
6870 when N_Parameter_Specification =>
6871 if Nkind (Parameter_Type (N)) = N_Access_Definition then
6872 return Null_Exclusion_Present (Parameter_Type (N));
6873 else
6874 return Null_Exclusion_Present (N);
6875 end if;
6877 when others =>
6878 return False;
6880 end case;
6881 end Has_Null_Exclusion;
6883 ------------------------
6884 -- Has_Null_Extension --
6885 ------------------------
6887 function Has_Null_Extension (T : Entity_Id) return Boolean is
6888 B : constant Entity_Id := Base_Type (T);
6889 Comps : Node_Id;
6890 Ext : Node_Id;
6892 begin
6893 if Nkind (Parent (B)) = N_Full_Type_Declaration
6894 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
6895 then
6896 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
6898 if Present (Ext) then
6899 if Null_Present (Ext) then
6900 return True;
6901 else
6902 Comps := Component_List (Ext);
6904 -- The null component list is rewritten during analysis to
6905 -- include the parent component. Any other component indicates
6906 -- that the extension was not originally null.
6908 return Null_Present (Comps)
6909 or else No (Next (First (Component_Items (Comps))));
6910 end if;
6911 else
6912 return False;
6913 end if;
6915 else
6916 return False;
6917 end if;
6918 end Has_Null_Extension;
6920 -------------------------------
6921 -- Has_Overriding_Initialize --
6922 -------------------------------
6924 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
6925 BT : constant Entity_Id := Base_Type (T);
6926 P : Elmt_Id;
6928 begin
6929 if Is_Controlled (BT) then
6930 if Is_RTU (Scope (BT), Ada_Finalization) then
6931 return False;
6933 elsif Present (Primitive_Operations (BT)) then
6934 P := First_Elmt (Primitive_Operations (BT));
6935 while Present (P) loop
6936 declare
6937 Init : constant Entity_Id := Node (P);
6938 Formal : constant Entity_Id := First_Formal (Init);
6939 begin
6940 if Ekind (Init) = E_Procedure
6941 and then Chars (Init) = Name_Initialize
6942 and then Comes_From_Source (Init)
6943 and then Present (Formal)
6944 and then Etype (Formal) = BT
6945 and then No (Next_Formal (Formal))
6946 and then (Ada_Version < Ada_2012
6947 or else not Null_Present (Parent (Init)))
6948 then
6949 return True;
6950 end if;
6951 end;
6953 Next_Elmt (P);
6954 end loop;
6955 end if;
6957 -- Here if type itself does not have a non-null Initialize operation:
6958 -- check immediate ancestor.
6960 if Is_Derived_Type (BT)
6961 and then Has_Overriding_Initialize (Etype (BT))
6962 then
6963 return True;
6964 end if;
6965 end if;
6967 return False;
6968 end Has_Overriding_Initialize;
6970 --------------------------------------
6971 -- Has_Preelaborable_Initialization --
6972 --------------------------------------
6974 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
6975 Has_PE : Boolean;
6977 procedure Check_Components (E : Entity_Id);
6978 -- Check component/discriminant chain, sets Has_PE False if a component
6979 -- or discriminant does not meet the preelaborable initialization rules.
6981 ----------------------
6982 -- Check_Components --
6983 ----------------------
6985 procedure Check_Components (E : Entity_Id) is
6986 Ent : Entity_Id;
6987 Exp : Node_Id;
6989 function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
6990 -- Returns True if and only if the expression denoted by N does not
6991 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
6993 ---------------------------------
6994 -- Is_Preelaborable_Expression --
6995 ---------------------------------
6997 function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
6998 Exp : Node_Id;
6999 Assn : Node_Id;
7000 Choice : Node_Id;
7001 Comp_Type : Entity_Id;
7002 Is_Array_Aggr : Boolean;
7004 begin
7005 if Is_Static_Expression (N) then
7006 return True;
7008 elsif Nkind (N) = N_Null then
7009 return True;
7011 -- Attributes are allowed in general, even if their prefix is a
7012 -- formal type. (It seems that certain attributes known not to be
7013 -- static might not be allowed, but there are no rules to prevent
7014 -- them.)
7016 elsif Nkind (N) = N_Attribute_Reference then
7017 return True;
7019 -- The name of a discriminant evaluated within its parent type is
7020 -- defined to be preelaborable (10.2.1(8)). Note that we test for
7021 -- names that denote discriminals as well as discriminants to
7022 -- catch references occurring within init procs.
7024 elsif Is_Entity_Name (N)
7025 and then
7026 (Ekind (Entity (N)) = E_Discriminant
7027 or else
7028 ((Ekind (Entity (N)) = E_Constant
7029 or else Ekind (Entity (N)) = E_In_Parameter)
7030 and then Present (Discriminal_Link (Entity (N)))))
7031 then
7032 return True;
7034 elsif Nkind (N) = N_Qualified_Expression then
7035 return Is_Preelaborable_Expression (Expression (N));
7037 -- For aggregates we have to check that each of the associations
7038 -- is preelaborable.
7040 elsif Nkind (N) = N_Aggregate
7041 or else Nkind (N) = N_Extension_Aggregate
7042 then
7043 Is_Array_Aggr := Is_Array_Type (Etype (N));
7045 if Is_Array_Aggr then
7046 Comp_Type := Component_Type (Etype (N));
7047 end if;
7049 -- Check the ancestor part of extension aggregates, which must
7050 -- be either the name of a type that has preelaborable init or
7051 -- an expression that is preelaborable.
7053 if Nkind (N) = N_Extension_Aggregate then
7054 declare
7055 Anc_Part : constant Node_Id := Ancestor_Part (N);
7057 begin
7058 if Is_Entity_Name (Anc_Part)
7059 and then Is_Type (Entity (Anc_Part))
7060 then
7061 if not Has_Preelaborable_Initialization
7062 (Entity (Anc_Part))
7063 then
7064 return False;
7065 end if;
7067 elsif not Is_Preelaborable_Expression (Anc_Part) then
7068 return False;
7069 end if;
7070 end;
7071 end if;
7073 -- Check positional associations
7075 Exp := First (Expressions (N));
7076 while Present (Exp) loop
7077 if not Is_Preelaborable_Expression (Exp) then
7078 return False;
7079 end if;
7081 Next (Exp);
7082 end loop;
7084 -- Check named associations
7086 Assn := First (Component_Associations (N));
7087 while Present (Assn) loop
7088 Choice := First (Choices (Assn));
7089 while Present (Choice) loop
7090 if Is_Array_Aggr then
7091 if Nkind (Choice) = N_Others_Choice then
7092 null;
7094 elsif Nkind (Choice) = N_Range then
7095 if not Is_Static_Range (Choice) then
7096 return False;
7097 end if;
7099 elsif not Is_Static_Expression (Choice) then
7100 return False;
7101 end if;
7103 else
7104 Comp_Type := Etype (Choice);
7105 end if;
7107 Next (Choice);
7108 end loop;
7110 -- If the association has a <> at this point, then we have
7111 -- to check whether the component's type has preelaborable
7112 -- initialization. Note that this only occurs when the
7113 -- association's corresponding component does not have a
7114 -- default expression, the latter case having already been
7115 -- expanded as an expression for the association.
7117 if Box_Present (Assn) then
7118 if not Has_Preelaborable_Initialization (Comp_Type) then
7119 return False;
7120 end if;
7122 -- In the expression case we check whether the expression
7123 -- is preelaborable.
7125 elsif
7126 not Is_Preelaborable_Expression (Expression (Assn))
7127 then
7128 return False;
7129 end if;
7131 Next (Assn);
7132 end loop;
7134 -- If we get here then aggregate as a whole is preelaborable
7136 return True;
7138 -- All other cases are not preelaborable
7140 else
7141 return False;
7142 end if;
7143 end Is_Preelaborable_Expression;
7145 -- Start of processing for Check_Components
7147 begin
7148 -- Loop through entities of record or protected type
7150 Ent := E;
7151 while Present (Ent) loop
7153 -- We are interested only in components and discriminants
7155 Exp := Empty;
7157 case Ekind (Ent) is
7158 when E_Component =>
7160 -- Get default expression if any. If there is no declaration
7161 -- node, it means we have an internal entity. The parent and
7162 -- tag fields are examples of such entities. For such cases,
7163 -- we just test the type of the entity.
7165 if Present (Declaration_Node (Ent)) then
7166 Exp := Expression (Declaration_Node (Ent));
7167 end if;
7169 when E_Discriminant =>
7171 -- Note: for a renamed discriminant, the Declaration_Node
7172 -- may point to the one from the ancestor, and have a
7173 -- different expression, so use the proper attribute to
7174 -- retrieve the expression from the derived constraint.
7176 Exp := Discriminant_Default_Value (Ent);
7178 when others =>
7179 goto Check_Next_Entity;
7180 end case;
7182 -- A component has PI if it has no default expression and the
7183 -- component type has PI.
7185 if No (Exp) then
7186 if not Has_Preelaborable_Initialization (Etype (Ent)) then
7187 Has_PE := False;
7188 exit;
7189 end if;
7191 -- Require the default expression to be preelaborable
7193 elsif not Is_Preelaborable_Expression (Exp) then
7194 Has_PE := False;
7195 exit;
7196 end if;
7198 <<Check_Next_Entity>>
7199 Next_Entity (Ent);
7200 end loop;
7201 end Check_Components;
7203 -- Start of processing for Has_Preelaborable_Initialization
7205 begin
7206 -- Immediate return if already marked as known preelaborable init. This
7207 -- covers types for which this function has already been called once
7208 -- and returned True (in which case the result is cached), and also
7209 -- types to which a pragma Preelaborable_Initialization applies.
7211 if Known_To_Have_Preelab_Init (E) then
7212 return True;
7213 end if;
7215 -- If the type is a subtype representing a generic actual type, then
7216 -- test whether its base type has preelaborable initialization since
7217 -- the subtype representing the actual does not inherit this attribute
7218 -- from the actual or formal. (but maybe it should???)
7220 if Is_Generic_Actual_Type (E) then
7221 return Has_Preelaborable_Initialization (Base_Type (E));
7222 end if;
7224 -- All elementary types have preelaborable initialization
7226 if Is_Elementary_Type (E) then
7227 Has_PE := True;
7229 -- Array types have PI if the component type has PI
7231 elsif Is_Array_Type (E) then
7232 Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
7234 -- A derived type has preelaborable initialization if its parent type
7235 -- has preelaborable initialization and (in the case of a derived record
7236 -- extension) if the non-inherited components all have preelaborable
7237 -- initialization. However, a user-defined controlled type with an
7238 -- overriding Initialize procedure does not have preelaborable
7239 -- initialization.
7241 elsif Is_Derived_Type (E) then
7243 -- If the derived type is a private extension then it doesn't have
7244 -- preelaborable initialization.
7246 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
7247 return False;
7248 end if;
7250 -- First check whether ancestor type has preelaborable initialization
7252 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
7254 -- If OK, check extension components (if any)
7256 if Has_PE and then Is_Record_Type (E) then
7257 Check_Components (First_Entity (E));
7258 end if;
7260 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
7261 -- with a user defined Initialize procedure does not have PI.
7263 if Has_PE
7264 and then Is_Controlled (E)
7265 and then Has_Overriding_Initialize (E)
7266 then
7267 Has_PE := False;
7268 end if;
7270 -- Private types not derived from a type having preelaborable init and
7271 -- that are not marked with pragma Preelaborable_Initialization do not
7272 -- have preelaborable initialization.
7274 elsif Is_Private_Type (E) then
7275 return False;
7277 -- Record type has PI if it is non private and all components have PI
7279 elsif Is_Record_Type (E) then
7280 Has_PE := True;
7281 Check_Components (First_Entity (E));
7283 -- Protected types must not have entries, and components must meet
7284 -- same set of rules as for record components.
7286 elsif Is_Protected_Type (E) then
7287 if Has_Entries (E) then
7288 Has_PE := False;
7289 else
7290 Has_PE := True;
7291 Check_Components (First_Entity (E));
7292 Check_Components (First_Private_Entity (E));
7293 end if;
7295 -- Type System.Address always has preelaborable initialization
7297 elsif Is_RTE (E, RE_Address) then
7298 Has_PE := True;
7300 -- In all other cases, type does not have preelaborable initialization
7302 else
7303 return False;
7304 end if;
7306 -- If type has preelaborable initialization, cache result
7308 if Has_PE then
7309 Set_Known_To_Have_Preelab_Init (E);
7310 end if;
7312 return Has_PE;
7313 end Has_Preelaborable_Initialization;
7315 ---------------------------
7316 -- Has_Private_Component --
7317 ---------------------------
7319 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
7320 Btype : Entity_Id := Base_Type (Type_Id);
7321 Component : Entity_Id;
7323 begin
7324 if Error_Posted (Type_Id)
7325 or else Error_Posted (Btype)
7326 then
7327 return False;
7328 end if;
7330 if Is_Class_Wide_Type (Btype) then
7331 Btype := Root_Type (Btype);
7332 end if;
7334 if Is_Private_Type (Btype) then
7335 declare
7336 UT : constant Entity_Id := Underlying_Type (Btype);
7337 begin
7338 if No (UT) then
7339 if No (Full_View (Btype)) then
7340 return not Is_Generic_Type (Btype)
7341 and then not Is_Generic_Type (Root_Type (Btype));
7342 else
7343 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
7344 end if;
7345 else
7346 return not Is_Frozen (UT) and then Has_Private_Component (UT);
7347 end if;
7348 end;
7350 elsif Is_Array_Type (Btype) then
7351 return Has_Private_Component (Component_Type (Btype));
7353 elsif Is_Record_Type (Btype) then
7354 Component := First_Component (Btype);
7355 while Present (Component) loop
7356 if Has_Private_Component (Etype (Component)) then
7357 return True;
7358 end if;
7360 Next_Component (Component);
7361 end loop;
7363 return False;
7365 elsif Is_Protected_Type (Btype)
7366 and then Present (Corresponding_Record_Type (Btype))
7367 then
7368 return Has_Private_Component (Corresponding_Record_Type (Btype));
7370 else
7371 return False;
7372 end if;
7373 end Has_Private_Component;
7375 ----------------------
7376 -- Has_Signed_Zeros --
7377 ----------------------
7379 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
7380 begin
7381 return Is_Floating_Point_Type (E)
7382 and then Signed_Zeros_On_Target
7383 and then not Vax_Float (E);
7384 end Has_Signed_Zeros;
7386 -----------------------------
7387 -- Has_Static_Array_Bounds --
7388 -----------------------------
7390 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
7391 Ndims : constant Nat := Number_Dimensions (Typ);
7393 Index : Node_Id;
7394 Low : Node_Id;
7395 High : Node_Id;
7397 begin
7398 -- Unconstrained types do not have static bounds
7400 if not Is_Constrained (Typ) then
7401 return False;
7402 end if;
7404 -- First treat string literals specially, as the lower bound and length
7405 -- of string literals are not stored like those of arrays.
7407 -- A string literal always has static bounds
7409 if Ekind (Typ) = E_String_Literal_Subtype then
7410 return True;
7411 end if;
7413 -- Treat all dimensions in turn
7415 Index := First_Index (Typ);
7416 for Indx in 1 .. Ndims loop
7418 -- In case of an erroneous index which is not a discrete type, return
7419 -- that the type is not static.
7421 if not Is_Discrete_Type (Etype (Index))
7422 or else Etype (Index) = Any_Type
7423 then
7424 return False;
7425 end if;
7427 Get_Index_Bounds (Index, Low, High);
7429 if Error_Posted (Low) or else Error_Posted (High) then
7430 return False;
7431 end if;
7433 if Is_OK_Static_Expression (Low)
7434 and then
7435 Is_OK_Static_Expression (High)
7436 then
7437 null;
7438 else
7439 return False;
7440 end if;
7442 Next (Index);
7443 end loop;
7445 -- If we fall through the loop, all indexes matched
7447 return True;
7448 end Has_Static_Array_Bounds;
7450 ----------------
7451 -- Has_Stream --
7452 ----------------
7454 function Has_Stream (T : Entity_Id) return Boolean is
7455 E : Entity_Id;
7457 begin
7458 if No (T) then
7459 return False;
7461 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
7462 return True;
7464 elsif Is_Array_Type (T) then
7465 return Has_Stream (Component_Type (T));
7467 elsif Is_Record_Type (T) then
7468 E := First_Component (T);
7469 while Present (E) loop
7470 if Has_Stream (Etype (E)) then
7471 return True;
7472 else
7473 Next_Component (E);
7474 end if;
7475 end loop;
7477 return False;
7479 elsif Is_Private_Type (T) then
7480 return Has_Stream (Underlying_Type (T));
7482 else
7483 return False;
7484 end if;
7485 end Has_Stream;
7487 ----------------
7488 -- Has_Suffix --
7489 ----------------
7491 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
7492 begin
7493 Get_Name_String (Chars (E));
7494 return Name_Buffer (Name_Len) = Suffix;
7495 end Has_Suffix;
7497 ----------------
7498 -- Add_Suffix --
7499 ----------------
7501 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
7502 begin
7503 Get_Name_String (Chars (E));
7504 Add_Char_To_Name_Buffer (Suffix);
7505 return Name_Find;
7506 end Add_Suffix;
7508 -------------------
7509 -- Remove_Suffix --
7510 -------------------
7512 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
7513 begin
7514 pragma Assert (Has_Suffix (E, Suffix));
7515 Get_Name_String (Chars (E));
7516 Name_Len := Name_Len - 1;
7517 return Name_Find;
7518 end Remove_Suffix;
7520 --------------------------
7521 -- Has_Tagged_Component --
7522 --------------------------
7524 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
7525 Comp : Entity_Id;
7527 begin
7528 if Is_Private_Type (Typ)
7529 and then Present (Underlying_Type (Typ))
7530 then
7531 return Has_Tagged_Component (Underlying_Type (Typ));
7533 elsif Is_Array_Type (Typ) then
7534 return Has_Tagged_Component (Component_Type (Typ));
7536 elsif Is_Tagged_Type (Typ) then
7537 return True;
7539 elsif Is_Record_Type (Typ) then
7540 Comp := First_Component (Typ);
7541 while Present (Comp) loop
7542 if Has_Tagged_Component (Etype (Comp)) then
7543 return True;
7544 end if;
7546 Next_Component (Comp);
7547 end loop;
7549 return False;
7551 else
7552 return False;
7553 end if;
7554 end Has_Tagged_Component;
7556 -------------------------
7557 -- Implementation_Kind --
7558 -------------------------
7560 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
7561 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
7562 Arg : Node_Id;
7563 begin
7564 pragma Assert (Present (Impl_Prag));
7565 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
7566 return Chars (Get_Pragma_Arg (Arg));
7567 end Implementation_Kind;
7569 --------------------------
7570 -- Implements_Interface --
7571 --------------------------
7573 function Implements_Interface
7574 (Typ_Ent : Entity_Id;
7575 Iface_Ent : Entity_Id;
7576 Exclude_Parents : Boolean := False) return Boolean
7578 Ifaces_List : Elist_Id;
7579 Elmt : Elmt_Id;
7580 Iface : Entity_Id := Base_Type (Iface_Ent);
7581 Typ : Entity_Id := Base_Type (Typ_Ent);
7583 begin
7584 if Is_Class_Wide_Type (Typ) then
7585 Typ := Root_Type (Typ);
7586 end if;
7588 if not Has_Interfaces (Typ) then
7589 return False;
7590 end if;
7592 if Is_Class_Wide_Type (Iface) then
7593 Iface := Root_Type (Iface);
7594 end if;
7596 Collect_Interfaces (Typ, Ifaces_List);
7598 Elmt := First_Elmt (Ifaces_List);
7599 while Present (Elmt) loop
7600 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
7601 and then Exclude_Parents
7602 then
7603 null;
7605 elsif Node (Elmt) = Iface then
7606 return True;
7607 end if;
7609 Next_Elmt (Elmt);
7610 end loop;
7612 return False;
7613 end Implements_Interface;
7615 -----------------
7616 -- In_Instance --
7617 -----------------
7619 function In_Instance return Boolean is
7620 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
7621 S : Entity_Id;
7623 begin
7624 S := Current_Scope;
7625 while Present (S)
7626 and then S /= Standard_Standard
7627 loop
7628 if (Ekind (S) = E_Function
7629 or else Ekind (S) = E_Package
7630 or else Ekind (S) = E_Procedure)
7631 and then Is_Generic_Instance (S)
7632 then
7633 -- A child instance is always compiled in the context of a parent
7634 -- instance. Nevertheless, the actuals are not analyzed in an
7635 -- instance context. We detect this case by examining the current
7636 -- compilation unit, which must be a child instance, and checking
7637 -- that it is not currently on the scope stack.
7639 if Is_Child_Unit (Curr_Unit)
7640 and then
7641 Nkind (Unit (Cunit (Current_Sem_Unit)))
7642 = N_Package_Instantiation
7643 and then not In_Open_Scopes (Curr_Unit)
7644 then
7645 return False;
7646 else
7647 return True;
7648 end if;
7649 end if;
7651 S := Scope (S);
7652 end loop;
7654 return False;
7655 end In_Instance;
7657 ----------------------
7658 -- In_Instance_Body --
7659 ----------------------
7661 function In_Instance_Body return Boolean is
7662 S : Entity_Id;
7664 begin
7665 S := Current_Scope;
7666 while Present (S)
7667 and then S /= Standard_Standard
7668 loop
7669 if (Ekind (S) = E_Function
7670 or else Ekind (S) = E_Procedure)
7671 and then Is_Generic_Instance (S)
7672 then
7673 return True;
7675 elsif Ekind (S) = E_Package
7676 and then In_Package_Body (S)
7677 and then Is_Generic_Instance (S)
7678 then
7679 return True;
7680 end if;
7682 S := Scope (S);
7683 end loop;
7685 return False;
7686 end In_Instance_Body;
7688 -----------------------------
7689 -- In_Instance_Not_Visible --
7690 -----------------------------
7692 function In_Instance_Not_Visible return Boolean is
7693 S : Entity_Id;
7695 begin
7696 S := Current_Scope;
7697 while Present (S)
7698 and then S /= Standard_Standard
7699 loop
7700 if (Ekind (S) = E_Function
7701 or else Ekind (S) = E_Procedure)
7702 and then Is_Generic_Instance (S)
7703 then
7704 return True;
7706 elsif Ekind (S) = E_Package
7707 and then (In_Package_Body (S) or else In_Private_Part (S))
7708 and then Is_Generic_Instance (S)
7709 then
7710 return True;
7711 end if;
7713 S := Scope (S);
7714 end loop;
7716 return False;
7717 end In_Instance_Not_Visible;
7719 ------------------------------
7720 -- In_Instance_Visible_Part --
7721 ------------------------------
7723 function In_Instance_Visible_Part return Boolean is
7724 S : Entity_Id;
7726 begin
7727 S := Current_Scope;
7728 while Present (S)
7729 and then S /= Standard_Standard
7730 loop
7731 if Ekind (S) = E_Package
7732 and then Is_Generic_Instance (S)
7733 and then not In_Package_Body (S)
7734 and then not In_Private_Part (S)
7735 then
7736 return True;
7737 end if;
7739 S := Scope (S);
7740 end loop;
7742 return False;
7743 end In_Instance_Visible_Part;
7745 ---------------------
7746 -- In_Package_Body --
7747 ---------------------
7749 function In_Package_Body return Boolean is
7750 S : Entity_Id;
7752 begin
7753 S := Current_Scope;
7754 while Present (S)
7755 and then S /= Standard_Standard
7756 loop
7757 if Ekind (S) = E_Package
7758 and then In_Package_Body (S)
7759 then
7760 return True;
7761 else
7762 S := Scope (S);
7763 end if;
7764 end loop;
7766 return False;
7767 end In_Package_Body;
7769 --------------------------------
7770 -- In_Parameter_Specification --
7771 --------------------------------
7773 function In_Parameter_Specification (N : Node_Id) return Boolean is
7774 PN : Node_Id;
7776 begin
7777 PN := Parent (N);
7778 while Present (PN) loop
7779 if Nkind (PN) = N_Parameter_Specification then
7780 return True;
7781 end if;
7783 PN := Parent (PN);
7784 end loop;
7786 return False;
7787 end In_Parameter_Specification;
7789 -------------------------------------
7790 -- In_Reverse_Storage_Order_Object --
7791 -------------------------------------
7793 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
7794 Pref : Node_Id;
7795 Btyp : Entity_Id := Empty;
7797 begin
7798 -- Climb up indexed components
7800 Pref := N;
7801 loop
7802 case Nkind (Pref) is
7803 when N_Selected_Component =>
7804 Pref := Prefix (Pref);
7805 exit;
7807 when N_Indexed_Component =>
7808 Pref := Prefix (Pref);
7810 when others =>
7811 Pref := Empty;
7812 exit;
7813 end case;
7814 end loop;
7816 if Present (Pref) then
7817 Btyp := Base_Type (Etype (Pref));
7818 end if;
7820 return
7821 Present (Btyp)
7822 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
7823 and then Reverse_Storage_Order (Btyp);
7824 end In_Reverse_Storage_Order_Object;
7826 --------------------------------------
7827 -- In_Subprogram_Or_Concurrent_Unit --
7828 --------------------------------------
7830 function In_Subprogram_Or_Concurrent_Unit return Boolean is
7831 E : Entity_Id;
7832 K : Entity_Kind;
7834 begin
7835 -- Use scope chain to check successively outer scopes
7837 E := Current_Scope;
7838 loop
7839 K := Ekind (E);
7841 if K in Subprogram_Kind
7842 or else K in Concurrent_Kind
7843 or else K in Generic_Subprogram_Kind
7844 then
7845 return True;
7847 elsif E = Standard_Standard then
7848 return False;
7849 end if;
7851 E := Scope (E);
7852 end loop;
7853 end In_Subprogram_Or_Concurrent_Unit;
7855 ---------------------
7856 -- In_Visible_Part --
7857 ---------------------
7859 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
7860 begin
7861 return
7862 Is_Package_Or_Generic_Package (Scope_Id)
7863 and then In_Open_Scopes (Scope_Id)
7864 and then not In_Package_Body (Scope_Id)
7865 and then not In_Private_Part (Scope_Id);
7866 end In_Visible_Part;
7868 --------------------------------
7869 -- Incomplete_Or_Private_View --
7870 --------------------------------
7872 function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is
7873 function Inspect_Decls
7874 (Decls : List_Id;
7875 Taft : Boolean := False) return Entity_Id;
7876 -- Check whether a declarative region contains the incomplete or private
7877 -- view of Typ.
7879 -------------------
7880 -- Inspect_Decls --
7881 -------------------
7883 function Inspect_Decls
7884 (Decls : List_Id;
7885 Taft : Boolean := False) return Entity_Id
7887 Decl : Node_Id;
7888 Match : Node_Id;
7890 begin
7891 Decl := First (Decls);
7892 while Present (Decl) loop
7893 Match := Empty;
7895 if Taft then
7896 if Nkind (Decl) = N_Incomplete_Type_Declaration then
7897 Match := Defining_Identifier (Decl);
7898 end if;
7900 else
7901 if Nkind_In (Decl, N_Private_Extension_Declaration,
7902 N_Private_Type_Declaration)
7903 then
7904 Match := Defining_Identifier (Decl);
7905 end if;
7906 end if;
7908 if Present (Match)
7909 and then Present (Full_View (Match))
7910 and then Full_View (Match) = Typ
7911 then
7912 return Match;
7913 end if;
7915 Next (Decl);
7916 end loop;
7918 return Empty;
7919 end Inspect_Decls;
7921 -- Local variables
7923 Prev : Entity_Id;
7925 -- Start of processing for Incomplete_Or_Partial_View
7927 begin
7928 -- Incomplete type case
7930 Prev := Current_Entity_In_Scope (Typ);
7932 if Present (Prev)
7933 and then Is_Incomplete_Type (Prev)
7934 and then Present (Full_View (Prev))
7935 and then Full_View (Prev) = Typ
7936 then
7937 return Prev;
7938 end if;
7940 -- Private or Taft amendment type case
7942 declare
7943 Pkg : constant Entity_Id := Scope (Typ);
7944 Pkg_Decl : Node_Id := Pkg;
7946 begin
7947 if Ekind (Pkg) = E_Package then
7948 while Nkind (Pkg_Decl) /= N_Package_Specification loop
7949 Pkg_Decl := Parent (Pkg_Decl);
7950 end loop;
7952 -- It is knows that Typ has a private view, look for it in the
7953 -- visible declarations of the enclosing scope. A special case
7954 -- of this is when the two views have been exchanged - the full
7955 -- appears earlier than the private.
7957 if Has_Private_Declaration (Typ) then
7958 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
7960 -- Exchanged view case, look in the private declarations
7962 if No (Prev) then
7963 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
7964 end if;
7966 return Prev;
7968 -- Otherwise if this is the package body, then Typ is a potential
7969 -- Taft amendment type. The incomplete view should be located in
7970 -- the private declarations of the enclosing scope.
7972 elsif In_Package_Body (Pkg) then
7973 return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
7974 end if;
7975 end if;
7976 end;
7978 -- The type has no incomplete or private view
7980 return Empty;
7981 end Incomplete_Or_Private_View;
7983 ---------------------------------
7984 -- Insert_Explicit_Dereference --
7985 ---------------------------------
7987 procedure Insert_Explicit_Dereference (N : Node_Id) is
7988 New_Prefix : constant Node_Id := Relocate_Node (N);
7989 Ent : Entity_Id := Empty;
7990 Pref : Node_Id;
7991 I : Interp_Index;
7992 It : Interp;
7993 T : Entity_Id;
7995 begin
7996 Save_Interps (N, New_Prefix);
7998 Rewrite (N,
7999 Make_Explicit_Dereference (Sloc (Parent (N)),
8000 Prefix => New_Prefix));
8002 Set_Etype (N, Designated_Type (Etype (New_Prefix)));
8004 if Is_Overloaded (New_Prefix) then
8006 -- The dereference is also overloaded, and its interpretations are
8007 -- the designated types of the interpretations of the original node.
8009 Set_Etype (N, Any_Type);
8011 Get_First_Interp (New_Prefix, I, It);
8012 while Present (It.Nam) loop
8013 T := It.Typ;
8015 if Is_Access_Type (T) then
8016 Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
8017 end if;
8019 Get_Next_Interp (I, It);
8020 end loop;
8022 End_Interp_List;
8024 else
8025 -- Prefix is unambiguous: mark the original prefix (which might
8026 -- Come_From_Source) as a reference, since the new (relocated) one
8027 -- won't be taken into account.
8029 if Is_Entity_Name (New_Prefix) then
8030 Ent := Entity (New_Prefix);
8031 Pref := New_Prefix;
8033 -- For a retrieval of a subcomponent of some composite object,
8034 -- retrieve the ultimate entity if there is one.
8036 elsif Nkind (New_Prefix) = N_Selected_Component
8037 or else Nkind (New_Prefix) = N_Indexed_Component
8038 then
8039 Pref := Prefix (New_Prefix);
8040 while Present (Pref)
8041 and then
8042 (Nkind (Pref) = N_Selected_Component
8043 or else Nkind (Pref) = N_Indexed_Component)
8044 loop
8045 Pref := Prefix (Pref);
8046 end loop;
8048 if Present (Pref) and then Is_Entity_Name (Pref) then
8049 Ent := Entity (Pref);
8050 end if;
8051 end if;
8053 -- Place the reference on the entity node
8055 if Present (Ent) then
8056 Generate_Reference (Ent, Pref);
8057 end if;
8058 end if;
8059 end Insert_Explicit_Dereference;
8061 ------------------------------------------
8062 -- Inspect_Deferred_Constant_Completion --
8063 ------------------------------------------
8065 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
8066 Decl : Node_Id;
8068 begin
8069 Decl := First (Decls);
8070 while Present (Decl) loop
8072 -- Deferred constant signature
8074 if Nkind (Decl) = N_Object_Declaration
8075 and then Constant_Present (Decl)
8076 and then No (Expression (Decl))
8078 -- No need to check internally generated constants
8080 and then Comes_From_Source (Decl)
8082 -- The constant is not completed. A full object declaration or a
8083 -- pragma Import complete a deferred constant.
8085 and then not Has_Completion (Defining_Identifier (Decl))
8086 then
8087 Error_Msg_N
8088 ("constant declaration requires initialization expression",
8089 Defining_Identifier (Decl));
8090 end if;
8092 Decl := Next (Decl);
8093 end loop;
8094 end Inspect_Deferred_Constant_Completion;
8096 -----------------------------
8097 -- Is_Actual_Out_Parameter --
8098 -----------------------------
8100 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
8101 Formal : Entity_Id;
8102 Call : Node_Id;
8103 begin
8104 Find_Actual (N, Formal, Call);
8105 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
8106 end Is_Actual_Out_Parameter;
8108 -------------------------
8109 -- Is_Actual_Parameter --
8110 -------------------------
8112 function Is_Actual_Parameter (N : Node_Id) return Boolean is
8113 PK : constant Node_Kind := Nkind (Parent (N));
8115 begin
8116 case PK is
8117 when N_Parameter_Association =>
8118 return N = Explicit_Actual_Parameter (Parent (N));
8120 when N_Subprogram_Call =>
8121 return Is_List_Member (N)
8122 and then
8123 List_Containing (N) = Parameter_Associations (Parent (N));
8125 when others =>
8126 return False;
8127 end case;
8128 end Is_Actual_Parameter;
8130 --------------------------------
8131 -- Is_Actual_Tagged_Parameter --
8132 --------------------------------
8134 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
8135 Formal : Entity_Id;
8136 Call : Node_Id;
8137 begin
8138 Find_Actual (N, Formal, Call);
8139 return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
8140 end Is_Actual_Tagged_Parameter;
8142 ---------------------
8143 -- Is_Aliased_View --
8144 ---------------------
8146 function Is_Aliased_View (Obj : Node_Id) return Boolean is
8147 E : Entity_Id;
8149 begin
8150 if Is_Entity_Name (Obj) then
8151 E := Entity (Obj);
8153 return
8154 (Is_Object (E)
8155 and then
8156 (Is_Aliased (E)
8157 or else (Present (Renamed_Object (E))
8158 and then Is_Aliased_View (Renamed_Object (E)))))
8160 or else ((Is_Formal (E)
8161 or else Ekind (E) = E_Generic_In_Out_Parameter
8162 or else Ekind (E) = E_Generic_In_Parameter)
8163 and then Is_Tagged_Type (Etype (E)))
8165 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
8167 -- Current instance of type, either directly or as rewritten
8168 -- reference to the current object.
8170 or else (Is_Entity_Name (Original_Node (Obj))
8171 and then Present (Entity (Original_Node (Obj)))
8172 and then Is_Type (Entity (Original_Node (Obj))))
8174 or else (Is_Type (E) and then E = Current_Scope)
8176 or else (Is_Incomplete_Or_Private_Type (E)
8177 and then Full_View (E) = Current_Scope)
8179 -- Ada 2012 AI05-0053: the return object of an extended return
8180 -- statement is aliased if its type is immutably limited.
8182 or else (Is_Return_Object (E)
8183 and then Is_Limited_View (Etype (E)));
8185 elsif Nkind (Obj) = N_Selected_Component then
8186 return Is_Aliased (Entity (Selector_Name (Obj)));
8188 elsif Nkind (Obj) = N_Indexed_Component then
8189 return Has_Aliased_Components (Etype (Prefix (Obj)))
8190 or else
8191 (Is_Access_Type (Etype (Prefix (Obj)))
8192 and then Has_Aliased_Components
8193 (Designated_Type (Etype (Prefix (Obj)))));
8195 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
8196 return Is_Tagged_Type (Etype (Obj))
8197 and then Is_Aliased_View (Expression (Obj));
8199 elsif Nkind (Obj) = N_Explicit_Dereference then
8200 return Nkind (Original_Node (Obj)) /= N_Function_Call;
8202 else
8203 return False;
8204 end if;
8205 end Is_Aliased_View;
8207 -------------------------
8208 -- Is_Ancestor_Package --
8209 -------------------------
8211 function Is_Ancestor_Package
8212 (E1 : Entity_Id;
8213 E2 : Entity_Id) return Boolean
8215 Par : Entity_Id;
8217 begin
8218 Par := E2;
8219 while Present (Par)
8220 and then Par /= Standard_Standard
8221 loop
8222 if Par = E1 then
8223 return True;
8224 end if;
8226 Par := Scope (Par);
8227 end loop;
8229 return False;
8230 end Is_Ancestor_Package;
8232 ----------------------
8233 -- Is_Atomic_Object --
8234 ----------------------
8236 function Is_Atomic_Object (N : Node_Id) return Boolean is
8238 function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
8239 -- Determines if given object has atomic components
8241 function Is_Atomic_Prefix (N : Node_Id) return Boolean;
8242 -- If prefix is an implicit dereference, examine designated type
8244 ----------------------
8245 -- Is_Atomic_Prefix --
8246 ----------------------
8248 function Is_Atomic_Prefix (N : Node_Id) return Boolean is
8249 begin
8250 if Is_Access_Type (Etype (N)) then
8251 return
8252 Has_Atomic_Components (Designated_Type (Etype (N)));
8253 else
8254 return Object_Has_Atomic_Components (N);
8255 end if;
8256 end Is_Atomic_Prefix;
8258 ----------------------------------
8259 -- Object_Has_Atomic_Components --
8260 ----------------------------------
8262 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
8263 begin
8264 if Has_Atomic_Components (Etype (N))
8265 or else Is_Atomic (Etype (N))
8266 then
8267 return True;
8269 elsif Is_Entity_Name (N)
8270 and then (Has_Atomic_Components (Entity (N))
8271 or else Is_Atomic (Entity (N)))
8272 then
8273 return True;
8275 elsif Nkind (N) = N_Selected_Component
8276 and then Is_Atomic (Entity (Selector_Name (N)))
8277 then
8278 return True;
8280 elsif Nkind (N) = N_Indexed_Component
8281 or else Nkind (N) = N_Selected_Component
8282 then
8283 return Is_Atomic_Prefix (Prefix (N));
8285 else
8286 return False;
8287 end if;
8288 end Object_Has_Atomic_Components;
8290 -- Start of processing for Is_Atomic_Object
8292 begin
8293 -- Predicate is not relevant to subprograms
8295 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
8296 return False;
8298 elsif Is_Atomic (Etype (N))
8299 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
8300 then
8301 return True;
8303 elsif Nkind (N) = N_Selected_Component
8304 and then Is_Atomic (Entity (Selector_Name (N)))
8305 then
8306 return True;
8308 elsif Nkind (N) = N_Indexed_Component
8309 or else Nkind (N) = N_Selected_Component
8310 then
8311 return Is_Atomic_Prefix (Prefix (N));
8313 else
8314 return False;
8315 end if;
8316 end Is_Atomic_Object;
8318 -------------------------
8319 -- Is_Attribute_Result --
8320 -------------------------
8322 function Is_Attribute_Result (N : Node_Id) return Boolean is
8323 begin
8324 return
8325 Nkind (N) = N_Attribute_Reference
8326 and then Attribute_Name (N) = Name_Result;
8327 end Is_Attribute_Result;
8329 ------------------------------------
8330 -- Is_Body_Or_Package_Declaration --
8331 ------------------------------------
8333 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is
8334 begin
8335 return Nkind_In (N, N_Entry_Body,
8336 N_Package_Body,
8337 N_Package_Declaration,
8338 N_Protected_Body,
8339 N_Subprogram_Body,
8340 N_Task_Body);
8341 end Is_Body_Or_Package_Declaration;
8343 -----------------------
8344 -- Is_Bounded_String --
8345 -----------------------
8347 function Is_Bounded_String (T : Entity_Id) return Boolean is
8348 Under : constant Entity_Id := Underlying_Type (Root_Type (T));
8350 begin
8351 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
8352 -- Super_String, or one of the [Wide_]Wide_ versions. This will
8353 -- be True for all the Bounded_String types in instances of the
8354 -- Generic_Bounded_Length generics, and for types derived from those.
8356 return Present (Under)
8357 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else
8358 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else
8359 Is_RTE (Root_Type (Under), RO_WW_Super_String));
8360 end Is_Bounded_String;
8362 -------------------------
8363 -- Is_Child_Or_Sibling --
8364 -------------------------
8366 function Is_Child_Or_Sibling
8367 (Pack_1 : Entity_Id;
8368 Pack_2 : Entity_Id;
8369 Private_Child : Boolean) return Boolean
8371 function Distance_From_Standard (Pack : Entity_Id) return Nat;
8372 -- Given an arbitrary package, return the number of "climbs" necessary
8373 -- to reach scope Standard_Standard.
8375 procedure Equalize_Depths
8376 (Pack : in out Entity_Id;
8377 Depth : in out Nat;
8378 Depth_To_Reach : Nat);
8379 -- Given an arbitrary package, its depth and a target depth to reach,
8380 -- climb the scope chain until the said depth is reached. The pointer
8381 -- to the package and its depth a modified during the climb.
8383 function Is_Child (Pack : Entity_Id) return Boolean;
8384 -- Given a package Pack, determine whether it is a child package that
8385 -- satisfies the privacy requirement (if set).
8387 ----------------------------
8388 -- Distance_From_Standard --
8389 ----------------------------
8391 function Distance_From_Standard (Pack : Entity_Id) return Nat is
8392 Dist : Nat;
8393 Scop : Entity_Id;
8395 begin
8396 Dist := 0;
8397 Scop := Pack;
8398 while Present (Scop) and then Scop /= Standard_Standard loop
8399 Dist := Dist + 1;
8400 Scop := Scope (Scop);
8401 end loop;
8403 return Dist;
8404 end Distance_From_Standard;
8406 ---------------------
8407 -- Equalize_Depths --
8408 ---------------------
8410 procedure Equalize_Depths
8411 (Pack : in out Entity_Id;
8412 Depth : in out Nat;
8413 Depth_To_Reach : Nat)
8415 begin
8416 -- The package must be at a greater or equal depth
8418 if Depth < Depth_To_Reach then
8419 raise Program_Error;
8420 end if;
8422 -- Climb the scope chain until the desired depth is reached
8424 while Present (Pack) and then Depth /= Depth_To_Reach loop
8425 Pack := Scope (Pack);
8426 Depth := Depth - 1;
8427 end loop;
8428 end Equalize_Depths;
8430 --------------
8431 -- Is_Child --
8432 --------------
8434 function Is_Child (Pack : Entity_Id) return Boolean is
8435 begin
8436 if Is_Child_Unit (Pack) then
8437 if Private_Child then
8438 return Is_Private_Descendant (Pack);
8439 else
8440 return True;
8441 end if;
8443 -- The package is nested, it cannot act a child or a sibling
8445 else
8446 return False;
8447 end if;
8448 end Is_Child;
8450 -- Local variables
8452 P_1 : Entity_Id := Pack_1;
8453 P_1_Child : Boolean := False;
8454 P_1_Depth : Nat := Distance_From_Standard (P_1);
8455 P_2 : Entity_Id := Pack_2;
8456 P_2_Child : Boolean := False;
8457 P_2_Depth : Nat := Distance_From_Standard (P_2);
8459 -- Start of processing for Is_Child_Or_Sibling
8461 begin
8462 pragma Assert
8463 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package);
8465 -- Both packages denote the same entity, therefore they cannot be
8466 -- children or siblings.
8468 if P_1 = P_2 then
8469 return False;
8471 -- One of the packages is at a deeper level than the other. Note that
8472 -- both may still come from differen hierarchies.
8474 -- (root) P_2
8475 -- / \ :
8476 -- X P_2 or X
8477 -- : :
8478 -- P_1 P_1
8480 elsif P_1_Depth > P_2_Depth then
8481 Equalize_Depths (P_1, P_1_Depth, P_2_Depth);
8482 P_1_Child := True;
8484 -- (root) P_1
8485 -- / \ :
8486 -- P_1 X or X
8487 -- : :
8488 -- P_2 P_2
8490 elsif P_2_Depth > P_1_Depth then
8491 Equalize_Depths (P_2, P_2_Depth, P_1_Depth);
8492 P_2_Child := True;
8493 end if;
8495 -- At this stage the package pointers have been elevated to the same
8496 -- depth. If the related entities are the same, then one package is a
8497 -- potential child of the other:
8499 -- P_1
8500 -- :
8501 -- X became P_1 P_2 or vica versa
8502 -- :
8503 -- P_2
8505 if P_1 = P_2 then
8506 if P_1_Child then
8507 return Is_Child (Pack_1);
8508 else pragma Assert (P_2_Child);
8509 return Is_Child (Pack_2);
8510 end if;
8512 -- The packages may come from the same package chain or from entirely
8513 -- different hierarcies. To determine this, climb the scope stack until
8514 -- a common root is found.
8516 -- (root) (root 1) (root 2)
8517 -- / \ | |
8518 -- P_1 P_2 P_1 P_2
8520 else
8521 while Present (P_1) and then Present (P_2) loop
8523 -- The two packages may be siblings
8525 if P_1 = P_2 then
8526 return Is_Child (Pack_1) and then Is_Child (Pack_2);
8527 end if;
8529 P_1 := Scope (P_1);
8530 P_2 := Scope (P_2);
8531 end loop;
8532 end if;
8534 return False;
8535 end Is_Child_Or_Sibling;
8537 -----------------------------
8538 -- Is_Concurrent_Interface --
8539 -----------------------------
8541 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
8542 begin
8543 return
8544 Is_Interface (T)
8545 and then
8546 (Is_Protected_Interface (T)
8547 or else Is_Synchronized_Interface (T)
8548 or else Is_Task_Interface (T));
8549 end Is_Concurrent_Interface;
8551 -----------------------
8552 -- Is_Constant_Bound --
8553 -----------------------
8555 function Is_Constant_Bound (Exp : Node_Id) return Boolean is
8556 begin
8557 if Compile_Time_Known_Value (Exp) then
8558 return True;
8560 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
8561 return Is_Constant_Object (Entity (Exp))
8562 or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
8564 elsif Nkind (Exp) in N_Binary_Op then
8565 return Is_Constant_Bound (Left_Opnd (Exp))
8566 and then Is_Constant_Bound (Right_Opnd (Exp))
8567 and then Scope (Entity (Exp)) = Standard_Standard;
8569 else
8570 return False;
8571 end if;
8572 end Is_Constant_Bound;
8574 --------------------------------------
8575 -- Is_Controlling_Limited_Procedure --
8576 --------------------------------------
8578 function Is_Controlling_Limited_Procedure
8579 (Proc_Nam : Entity_Id) return Boolean
8581 Param_Typ : Entity_Id := Empty;
8583 begin
8584 if Ekind (Proc_Nam) = E_Procedure
8585 and then Present (Parameter_Specifications (Parent (Proc_Nam)))
8586 then
8587 Param_Typ := Etype (Parameter_Type (First (
8588 Parameter_Specifications (Parent (Proc_Nam)))));
8590 -- In this case where an Itype was created, the procedure call has been
8591 -- rewritten.
8593 elsif Present (Associated_Node_For_Itype (Proc_Nam))
8594 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
8595 and then
8596 Present (Parameter_Associations
8597 (Associated_Node_For_Itype (Proc_Nam)))
8598 then
8599 Param_Typ :=
8600 Etype (First (Parameter_Associations
8601 (Associated_Node_For_Itype (Proc_Nam))));
8602 end if;
8604 if Present (Param_Typ) then
8605 return
8606 Is_Interface (Param_Typ)
8607 and then Is_Limited_Record (Param_Typ);
8608 end if;
8610 return False;
8611 end Is_Controlling_Limited_Procedure;
8613 -----------------------------
8614 -- Is_CPP_Constructor_Call --
8615 -----------------------------
8617 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
8618 begin
8619 return Nkind (N) = N_Function_Call
8620 and then Is_CPP_Class (Etype (Etype (N)))
8621 and then Is_Constructor (Entity (Name (N)))
8622 and then Is_Imported (Entity (Name (N)));
8623 end Is_CPP_Constructor_Call;
8625 -----------------
8626 -- Is_Delegate --
8627 -----------------
8629 function Is_Delegate (T : Entity_Id) return Boolean is
8630 Desig_Type : Entity_Id;
8632 begin
8633 if VM_Target /= CLI_Target then
8634 return False;
8635 end if;
8637 -- Access-to-subprograms are delegates in CIL
8639 if Ekind (T) = E_Access_Subprogram_Type then
8640 return True;
8641 end if;
8643 if Ekind (T) not in Access_Kind then
8645 -- A delegate is a managed pointer. If no designated type is defined
8646 -- it means that it's not a delegate.
8648 return False;
8649 end if;
8651 Desig_Type := Etype (Directly_Designated_Type (T));
8653 if not Is_Tagged_Type (Desig_Type) then
8654 return False;
8655 end if;
8657 -- Test if the type is inherited from [mscorlib]System.Delegate
8659 while Etype (Desig_Type) /= Desig_Type loop
8660 if Chars (Scope (Desig_Type)) /= No_Name
8661 and then Is_Imported (Scope (Desig_Type))
8662 and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
8663 then
8664 return True;
8665 end if;
8667 Desig_Type := Etype (Desig_Type);
8668 end loop;
8670 return False;
8671 end Is_Delegate;
8673 ----------------------------------------------
8674 -- Is_Dependent_Component_Of_Mutable_Object --
8675 ----------------------------------------------
8677 function Is_Dependent_Component_Of_Mutable_Object
8678 (Object : Node_Id) return Boolean
8680 P : Node_Id;
8681 Prefix_Type : Entity_Id;
8682 P_Aliased : Boolean := False;
8683 Comp : Entity_Id;
8685 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
8686 -- Returns True if and only if Comp is declared within a variant part
8688 --------------------------------
8689 -- Is_Declared_Within_Variant --
8690 --------------------------------
8692 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
8693 Comp_Decl : constant Node_Id := Parent (Comp);
8694 Comp_List : constant Node_Id := Parent (Comp_Decl);
8695 begin
8696 return Nkind (Parent (Comp_List)) = N_Variant;
8697 end Is_Declared_Within_Variant;
8699 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
8701 begin
8702 if Is_Variable (Object) then
8704 if Nkind (Object) = N_Selected_Component then
8705 P := Prefix (Object);
8706 Prefix_Type := Etype (P);
8708 if Is_Entity_Name (P) then
8710 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
8711 Prefix_Type := Base_Type (Prefix_Type);
8712 end if;
8714 if Is_Aliased (Entity (P)) then
8715 P_Aliased := True;
8716 end if;
8718 -- A discriminant check on a selected component may be expanded
8719 -- into a dereference when removing side-effects. Recover the
8720 -- original node and its type, which may be unconstrained.
8722 elsif Nkind (P) = N_Explicit_Dereference
8723 and then not (Comes_From_Source (P))
8724 then
8725 P := Original_Node (P);
8726 Prefix_Type := Etype (P);
8728 else
8729 -- Check for prefix being an aliased component???
8731 null;
8733 end if;
8735 -- A heap object is constrained by its initial value
8737 -- Ada 2005 (AI-363): Always assume the object could be mutable in
8738 -- the dereferenced case, since the access value might denote an
8739 -- unconstrained aliased object, whereas in Ada 95 the designated
8740 -- object is guaranteed to be constrained. A worst-case assumption
8741 -- has to apply in Ada 2005 because we can't tell at compile time
8742 -- whether the object is "constrained by its initial value"
8743 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
8744 -- semantic rules -- these rules are acknowledged to need fixing).
8746 if Ada_Version < Ada_2005 then
8747 if Is_Access_Type (Prefix_Type)
8748 or else Nkind (P) = N_Explicit_Dereference
8749 then
8750 return False;
8751 end if;
8753 elsif Ada_Version >= Ada_2005 then
8754 if Is_Access_Type (Prefix_Type) then
8756 -- If the access type is pool-specific, and there is no
8757 -- constrained partial view of the designated type, then the
8758 -- designated object is known to be constrained.
8760 if Ekind (Prefix_Type) = E_Access_Type
8761 and then not Object_Type_Has_Constrained_Partial_View
8762 (Typ => Designated_Type (Prefix_Type),
8763 Scop => Current_Scope)
8764 then
8765 return False;
8767 -- Otherwise (general access type, or there is a constrained
8768 -- partial view of the designated type), we need to check
8769 -- based on the designated type.
8771 else
8772 Prefix_Type := Designated_Type (Prefix_Type);
8773 end if;
8774 end if;
8775 end if;
8777 Comp :=
8778 Original_Record_Component (Entity (Selector_Name (Object)));
8780 -- As per AI-0017, the renaming is illegal in a generic body, even
8781 -- if the subtype is indefinite.
8783 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
8785 if not Is_Constrained (Prefix_Type)
8786 and then (not Is_Indefinite_Subtype (Prefix_Type)
8787 or else
8788 (Is_Generic_Type (Prefix_Type)
8789 and then Ekind (Current_Scope) = E_Generic_Package
8790 and then In_Package_Body (Current_Scope)))
8792 and then (Is_Declared_Within_Variant (Comp)
8793 or else Has_Discriminant_Dependent_Constraint (Comp))
8794 and then (not P_Aliased or else Ada_Version >= Ada_2005)
8795 then
8796 return True;
8798 -- If the prefix is of an access type at this point, then we want
8799 -- to return False, rather than calling this function recursively
8800 -- on the access object (which itself might be a discriminant-
8801 -- dependent component of some other object, but that isn't
8802 -- relevant to checking the object passed to us). This avoids
8803 -- issuing wrong errors when compiling with -gnatc, where there
8804 -- can be implicit dereferences that have not been expanded.
8806 elsif Is_Access_Type (Etype (Prefix (Object))) then
8807 return False;
8809 else
8810 return
8811 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
8812 end if;
8814 elsif Nkind (Object) = N_Indexed_Component
8815 or else Nkind (Object) = N_Slice
8816 then
8817 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
8819 -- A type conversion that Is_Variable is a view conversion:
8820 -- go back to the denoted object.
8822 elsif Nkind (Object) = N_Type_Conversion then
8823 return
8824 Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
8825 end if;
8826 end if;
8828 return False;
8829 end Is_Dependent_Component_Of_Mutable_Object;
8831 ---------------------
8832 -- Is_Dereferenced --
8833 ---------------------
8835 function Is_Dereferenced (N : Node_Id) return Boolean is
8836 P : constant Node_Id := Parent (N);
8837 begin
8838 return
8839 (Nkind (P) = N_Selected_Component
8840 or else
8841 Nkind (P) = N_Explicit_Dereference
8842 or else
8843 Nkind (P) = N_Indexed_Component
8844 or else
8845 Nkind (P) = N_Slice)
8846 and then Prefix (P) = N;
8847 end Is_Dereferenced;
8849 ----------------------
8850 -- Is_Descendent_Of --
8851 ----------------------
8853 function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
8854 T : Entity_Id;
8855 Etyp : Entity_Id;
8857 begin
8858 pragma Assert (Nkind (T1) in N_Entity);
8859 pragma Assert (Nkind (T2) in N_Entity);
8861 T := Base_Type (T1);
8863 -- Immediate return if the types match
8865 if T = T2 then
8866 return True;
8868 -- Comment needed here ???
8870 elsif Ekind (T) = E_Class_Wide_Type then
8871 return Etype (T) = T2;
8873 -- All other cases
8875 else
8876 loop
8877 Etyp := Etype (T);
8879 -- Done if we found the type we are looking for
8881 if Etyp = T2 then
8882 return True;
8884 -- Done if no more derivations to check
8886 elsif T = T1
8887 or else T = Etyp
8888 then
8889 return False;
8891 -- Following test catches error cases resulting from prev errors
8893 elsif No (Etyp) then
8894 return False;
8896 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
8897 return False;
8899 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
8900 return False;
8901 end if;
8903 T := Base_Type (Etyp);
8904 end loop;
8905 end if;
8906 end Is_Descendent_Of;
8908 ----------------------------
8909 -- Is_Expression_Function --
8910 ----------------------------
8912 function Is_Expression_Function (Subp : Entity_Id) return Boolean is
8913 Decl : Node_Id;
8915 begin
8916 if Ekind (Subp) /= E_Function then
8917 return False;
8919 else
8920 Decl := Unit_Declaration_Node (Subp);
8921 return Nkind (Decl) = N_Subprogram_Declaration
8922 and then
8923 (Nkind (Original_Node (Decl)) = N_Expression_Function
8924 or else
8925 (Present (Corresponding_Body (Decl))
8926 and then
8927 Nkind (Original_Node
8928 (Unit_Declaration_Node
8929 (Corresponding_Body (Decl)))) =
8930 N_Expression_Function));
8931 end if;
8932 end Is_Expression_Function;
8934 --------------
8935 -- Is_False --
8936 --------------
8938 function Is_False (U : Uint) return Boolean is
8939 begin
8940 return (U = 0);
8941 end Is_False;
8943 ---------------------------
8944 -- Is_Fixed_Model_Number --
8945 ---------------------------
8947 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
8948 S : constant Ureal := Small_Value (T);
8949 M : Urealp.Save_Mark;
8950 R : Boolean;
8951 begin
8952 M := Urealp.Mark;
8953 R := (U = UR_Trunc (U / S) * S);
8954 Urealp.Release (M);
8955 return R;
8956 end Is_Fixed_Model_Number;
8958 -------------------------------
8959 -- Is_Fully_Initialized_Type --
8960 -------------------------------
8962 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
8963 begin
8964 -- In Ada2012, a scalar type with an aspect Default_Value
8965 -- is fully initialized.
8967 if Is_Scalar_Type (Typ) then
8968 return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ);
8970 elsif Is_Access_Type (Typ) then
8971 return True;
8973 elsif Is_Array_Type (Typ) then
8974 if Is_Fully_Initialized_Type (Component_Type (Typ))
8975 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
8976 then
8977 return True;
8978 end if;
8980 -- An interesting case, if we have a constrained type one of whose
8981 -- bounds is known to be null, then there are no elements to be
8982 -- initialized, so all the elements are initialized!
8984 if Is_Constrained (Typ) then
8985 declare
8986 Indx : Node_Id;
8987 Indx_Typ : Entity_Id;
8988 Lbd, Hbd : Node_Id;
8990 begin
8991 Indx := First_Index (Typ);
8992 while Present (Indx) loop
8993 if Etype (Indx) = Any_Type then
8994 return False;
8996 -- If index is a range, use directly
8998 elsif Nkind (Indx) = N_Range then
8999 Lbd := Low_Bound (Indx);
9000 Hbd := High_Bound (Indx);
9002 else
9003 Indx_Typ := Etype (Indx);
9005 if Is_Private_Type (Indx_Typ) then
9006 Indx_Typ := Full_View (Indx_Typ);
9007 end if;
9009 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
9010 return False;
9011 else
9012 Lbd := Type_Low_Bound (Indx_Typ);
9013 Hbd := Type_High_Bound (Indx_Typ);
9014 end if;
9015 end if;
9017 if Compile_Time_Known_Value (Lbd)
9018 and then Compile_Time_Known_Value (Hbd)
9019 then
9020 if Expr_Value (Hbd) < Expr_Value (Lbd) then
9021 return True;
9022 end if;
9023 end if;
9025 Next_Index (Indx);
9026 end loop;
9027 end;
9028 end if;
9030 -- If no null indexes, then type is not fully initialized
9032 return False;
9034 -- Record types
9036 elsif Is_Record_Type (Typ) then
9037 if Has_Discriminants (Typ)
9038 and then
9039 Present (Discriminant_Default_Value (First_Discriminant (Typ)))
9040 and then Is_Fully_Initialized_Variant (Typ)
9041 then
9042 return True;
9043 end if;
9045 -- We consider bounded string types to be fully initialized, because
9046 -- otherwise we get false alarms when the Data component is not
9047 -- default-initialized.
9049 if Is_Bounded_String (Typ) then
9050 return True;
9051 end if;
9053 -- Controlled records are considered to be fully initialized if
9054 -- there is a user defined Initialize routine. This may not be
9055 -- entirely correct, but as the spec notes, we are guessing here
9056 -- what is best from the point of view of issuing warnings.
9058 if Is_Controlled (Typ) then
9059 declare
9060 Utyp : constant Entity_Id := Underlying_Type (Typ);
9062 begin
9063 if Present (Utyp) then
9064 declare
9065 Init : constant Entity_Id :=
9066 (Find_Prim_Op
9067 (Underlying_Type (Typ), Name_Initialize));
9069 begin
9070 if Present (Init)
9071 and then Comes_From_Source (Init)
9072 and then not
9073 Is_Predefined_File_Name
9074 (File_Name (Get_Source_File_Index (Sloc (Init))))
9075 then
9076 return True;
9078 elsif Has_Null_Extension (Typ)
9079 and then
9080 Is_Fully_Initialized_Type
9081 (Etype (Base_Type (Typ)))
9082 then
9083 return True;
9084 end if;
9085 end;
9086 end if;
9087 end;
9088 end if;
9090 -- Otherwise see if all record components are initialized
9092 declare
9093 Ent : Entity_Id;
9095 begin
9096 Ent := First_Entity (Typ);
9097 while Present (Ent) loop
9098 if Ekind (Ent) = E_Component
9099 and then (No (Parent (Ent))
9100 or else No (Expression (Parent (Ent))))
9101 and then not Is_Fully_Initialized_Type (Etype (Ent))
9103 -- Special VM case for tag components, which need to be
9104 -- defined in this case, but are never initialized as VMs
9105 -- are using other dispatching mechanisms. Ignore this
9106 -- uninitialized case. Note that this applies both to the
9107 -- uTag entry and the main vtable pointer (CPP_Class case).
9109 and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
9110 then
9111 return False;
9112 end if;
9114 Next_Entity (Ent);
9115 end loop;
9116 end;
9118 -- No uninitialized components, so type is fully initialized.
9119 -- Note that this catches the case of no components as well.
9121 return True;
9123 elsif Is_Concurrent_Type (Typ) then
9124 return True;
9126 elsif Is_Private_Type (Typ) then
9127 declare
9128 U : constant Entity_Id := Underlying_Type (Typ);
9130 begin
9131 if No (U) then
9132 return False;
9133 else
9134 return Is_Fully_Initialized_Type (U);
9135 end if;
9136 end;
9138 else
9139 return False;
9140 end if;
9141 end Is_Fully_Initialized_Type;
9143 ----------------------------------
9144 -- Is_Fully_Initialized_Variant --
9145 ----------------------------------
9147 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
9148 Loc : constant Source_Ptr := Sloc (Typ);
9149 Constraints : constant List_Id := New_List;
9150 Components : constant Elist_Id := New_Elmt_List;
9151 Comp_Elmt : Elmt_Id;
9152 Comp_Id : Node_Id;
9153 Comp_List : Node_Id;
9154 Discr : Entity_Id;
9155 Discr_Val : Node_Id;
9157 Report_Errors : Boolean;
9158 pragma Warnings (Off, Report_Errors);
9160 begin
9161 if Serious_Errors_Detected > 0 then
9162 return False;
9163 end if;
9165 if Is_Record_Type (Typ)
9166 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
9167 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
9168 then
9169 Comp_List := Component_List (Type_Definition (Parent (Typ)));
9171 Discr := First_Discriminant (Typ);
9172 while Present (Discr) loop
9173 if Nkind (Parent (Discr)) = N_Discriminant_Specification then
9174 Discr_Val := Expression (Parent (Discr));
9176 if Present (Discr_Val)
9177 and then Is_OK_Static_Expression (Discr_Val)
9178 then
9179 Append_To (Constraints,
9180 Make_Component_Association (Loc,
9181 Choices => New_List (New_Occurrence_Of (Discr, Loc)),
9182 Expression => New_Copy (Discr_Val)));
9183 else
9184 return False;
9185 end if;
9186 else
9187 return False;
9188 end if;
9190 Next_Discriminant (Discr);
9191 end loop;
9193 Gather_Components
9194 (Typ => Typ,
9195 Comp_List => Comp_List,
9196 Governed_By => Constraints,
9197 Into => Components,
9198 Report_Errors => Report_Errors);
9200 -- Check that each component present is fully initialized
9202 Comp_Elmt := First_Elmt (Components);
9203 while Present (Comp_Elmt) loop
9204 Comp_Id := Node (Comp_Elmt);
9206 if Ekind (Comp_Id) = E_Component
9207 and then (No (Parent (Comp_Id))
9208 or else No (Expression (Parent (Comp_Id))))
9209 and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
9210 then
9211 return False;
9212 end if;
9214 Next_Elmt (Comp_Elmt);
9215 end loop;
9217 return True;
9219 elsif Is_Private_Type (Typ) then
9220 declare
9221 U : constant Entity_Id := Underlying_Type (Typ);
9223 begin
9224 if No (U) then
9225 return False;
9226 else
9227 return Is_Fully_Initialized_Variant (U);
9228 end if;
9229 end;
9231 else
9232 return False;
9233 end if;
9234 end Is_Fully_Initialized_Variant;
9236 ----------------------------
9237 -- Is_Inherited_Operation --
9238 ----------------------------
9240 function Is_Inherited_Operation (E : Entity_Id) return Boolean is
9241 pragma Assert (Is_Overloadable (E));
9242 Kind : constant Node_Kind := Nkind (Parent (E));
9243 begin
9244 return Kind = N_Full_Type_Declaration
9245 or else Kind = N_Private_Extension_Declaration
9246 or else Kind = N_Subtype_Declaration
9247 or else (Ekind (E) = E_Enumeration_Literal
9248 and then Is_Derived_Type (Etype (E)));
9249 end Is_Inherited_Operation;
9251 -------------------------------------
9252 -- Is_Inherited_Operation_For_Type --
9253 -------------------------------------
9255 function Is_Inherited_Operation_For_Type
9256 (E : Entity_Id;
9257 Typ : Entity_Id) return Boolean
9259 begin
9260 -- Check that the operation has been created by the type declaration
9262 return Is_Inherited_Operation (E)
9263 and then Defining_Identifier (Parent (E)) = Typ;
9264 end Is_Inherited_Operation_For_Type;
9266 -----------------
9267 -- Is_Iterator --
9268 -----------------
9270 function Is_Iterator (Typ : Entity_Id) return Boolean is
9271 Ifaces_List : Elist_Id;
9272 Iface_Elmt : Elmt_Id;
9273 Iface : Entity_Id;
9275 begin
9276 if Is_Class_Wide_Type (Typ)
9277 and then
9278 Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator,
9279 Name_Reversible_Iterator)
9280 and then
9281 Is_Predefined_File_Name
9282 (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
9283 then
9284 return True;
9286 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
9287 return False;
9289 else
9290 Collect_Interfaces (Typ, Ifaces_List);
9292 Iface_Elmt := First_Elmt (Ifaces_List);
9293 while Present (Iface_Elmt) loop
9294 Iface := Node (Iface_Elmt);
9295 if Chars (Iface) = Name_Forward_Iterator
9296 and then
9297 Is_Predefined_File_Name
9298 (Unit_File_Name (Get_Source_Unit (Iface)))
9299 then
9300 return True;
9301 end if;
9303 Next_Elmt (Iface_Elmt);
9304 end loop;
9306 return False;
9307 end if;
9308 end Is_Iterator;
9310 ------------
9311 -- Is_LHS --
9312 ------------
9314 -- We seem to have a lot of overlapping functions that do similar things
9315 -- (testing for left hand sides or lvalues???). Anyway, since this one is
9316 -- purely syntactic, it should be in Sem_Aux I would think???
9318 function Is_LHS (N : Node_Id) return Boolean is
9319 P : constant Node_Id := Parent (N);
9321 begin
9322 if Nkind (P) = N_Assignment_Statement then
9323 return Name (P) = N;
9325 elsif
9326 Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
9327 then
9328 return N = Prefix (P) and then Is_LHS (P);
9330 else
9331 return False;
9332 end if;
9333 end Is_LHS;
9335 -----------------------------
9336 -- Is_Library_Level_Entity --
9337 -----------------------------
9339 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
9340 begin
9341 -- The following is a small optimization, and it also properly handles
9342 -- discriminals, which in task bodies might appear in expressions before
9343 -- the corresponding procedure has been created, and which therefore do
9344 -- not have an assigned scope.
9346 if Is_Formal (E) then
9347 return False;
9348 end if;
9350 -- Normal test is simply that the enclosing dynamic scope is Standard
9352 return Enclosing_Dynamic_Scope (E) = Standard_Standard;
9353 end Is_Library_Level_Entity;
9355 --------------------------------
9356 -- Is_Limited_Class_Wide_Type --
9357 --------------------------------
9359 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
9360 begin
9361 return
9362 Is_Class_Wide_Type (Typ)
9363 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ));
9364 end Is_Limited_Class_Wide_Type;
9366 ---------------------------------
9367 -- Is_Local_Variable_Reference --
9368 ---------------------------------
9370 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
9371 begin
9372 if not Is_Entity_Name (Expr) then
9373 return False;
9375 else
9376 declare
9377 Ent : constant Entity_Id := Entity (Expr);
9378 Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
9379 begin
9380 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
9381 return False;
9382 else
9383 return Present (Sub) and then Sub = Current_Subprogram;
9384 end if;
9385 end;
9386 end if;
9387 end Is_Local_Variable_Reference;
9389 -------------------------
9390 -- Is_Object_Reference --
9391 -------------------------
9393 function Is_Object_Reference (N : Node_Id) return Boolean is
9395 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
9396 -- Determine whether N is the name of an internally-generated renaming
9398 --------------------------------------
9399 -- Is_Internally_Generated_Renaming --
9400 --------------------------------------
9402 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
9403 P : Node_Id;
9405 begin
9406 P := N;
9407 while Present (P) loop
9408 if Nkind (P) = N_Object_Renaming_Declaration then
9409 return not Comes_From_Source (P);
9410 elsif Is_List_Member (P) then
9411 return False;
9412 end if;
9414 P := Parent (P);
9415 end loop;
9417 return False;
9418 end Is_Internally_Generated_Renaming;
9420 -- Start of processing for Is_Object_Reference
9422 begin
9423 if Is_Entity_Name (N) then
9424 return Present (Entity (N)) and then Is_Object (Entity (N));
9426 else
9427 case Nkind (N) is
9428 when N_Indexed_Component | N_Slice =>
9429 return
9430 Is_Object_Reference (Prefix (N))
9431 or else Is_Access_Type (Etype (Prefix (N)));
9433 -- In Ada 95, a function call is a constant object; a procedure
9434 -- call is not.
9436 when N_Function_Call =>
9437 return Etype (N) /= Standard_Void_Type;
9439 -- Attributes 'Input, 'Old and 'Result produce objects
9441 when N_Attribute_Reference =>
9442 return
9443 Nam_In
9444 (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
9446 when N_Selected_Component =>
9447 return
9448 Is_Object_Reference (Selector_Name (N))
9449 and then
9450 (Is_Object_Reference (Prefix (N))
9451 or else Is_Access_Type (Etype (Prefix (N))));
9453 when N_Explicit_Dereference =>
9454 return True;
9456 -- A view conversion of a tagged object is an object reference
9458 when N_Type_Conversion =>
9459 return Is_Tagged_Type (Etype (Subtype_Mark (N)))
9460 and then Is_Tagged_Type (Etype (Expression (N)))
9461 and then Is_Object_Reference (Expression (N));
9463 -- An unchecked type conversion is considered to be an object if
9464 -- the operand is an object (this construction arises only as a
9465 -- result of expansion activities).
9467 when N_Unchecked_Type_Conversion =>
9468 return True;
9470 -- Allow string literals to act as objects as long as they appear
9471 -- in internally-generated renamings. The expansion of iterators
9472 -- may generate such renamings when the range involves a string
9473 -- literal.
9475 when N_String_Literal =>
9476 return Is_Internally_Generated_Renaming (Parent (N));
9478 -- AI05-0003: In Ada 2012 a qualified expression is a name.
9479 -- This allows disambiguation of function calls and the use
9480 -- of aggregates in more contexts.
9482 when N_Qualified_Expression =>
9483 if Ada_Version < Ada_2012 then
9484 return False;
9485 else
9486 return Is_Object_Reference (Expression (N))
9487 or else Nkind (Expression (N)) = N_Aggregate;
9488 end if;
9490 when others =>
9491 return False;
9492 end case;
9493 end if;
9494 end Is_Object_Reference;
9496 -----------------------------------
9497 -- Is_OK_Variable_For_Out_Formal --
9498 -----------------------------------
9500 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
9501 begin
9502 Note_Possible_Modification (AV, Sure => True);
9504 -- We must reject parenthesized variable names. Comes_From_Source is
9505 -- checked because there are currently cases where the compiler violates
9506 -- this rule (e.g. passing a task object to its controlled Initialize
9507 -- routine). This should be properly documented in sinfo???
9509 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
9510 return False;
9512 -- A variable is always allowed
9514 elsif Is_Variable (AV) then
9515 return True;
9517 -- Unchecked conversions are allowed only if they come from the
9518 -- generated code, which sometimes uses unchecked conversions for out
9519 -- parameters in cases where code generation is unaffected. We tell
9520 -- source unchecked conversions by seeing if they are rewrites of
9521 -- an original Unchecked_Conversion function call, or of an explicit
9522 -- conversion of a function call or an aggregate (as may happen in the
9523 -- expansion of a packed array aggregate).
9525 elsif Nkind (AV) = N_Unchecked_Type_Conversion then
9526 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then
9527 return False;
9529 elsif Comes_From_Source (AV)
9530 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
9531 then
9532 return False;
9534 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
9535 return Is_OK_Variable_For_Out_Formal (Expression (AV));
9537 else
9538 return True;
9539 end if;
9541 -- Normal type conversions are allowed if argument is a variable
9543 elsif Nkind (AV) = N_Type_Conversion then
9544 if Is_Variable (Expression (AV))
9545 and then Paren_Count (Expression (AV)) = 0
9546 then
9547 Note_Possible_Modification (Expression (AV), Sure => True);
9548 return True;
9550 -- We also allow a non-parenthesized expression that raises
9551 -- constraint error if it rewrites what used to be a variable
9553 elsif Raises_Constraint_Error (Expression (AV))
9554 and then Paren_Count (Expression (AV)) = 0
9555 and then Is_Variable (Original_Node (Expression (AV)))
9556 then
9557 return True;
9559 -- Type conversion of something other than a variable
9561 else
9562 return False;
9563 end if;
9565 -- If this node is rewritten, then test the original form, if that is
9566 -- OK, then we consider the rewritten node OK (for example, if the
9567 -- original node is a conversion, then Is_Variable will not be true
9568 -- but we still want to allow the conversion if it converts a variable).
9570 elsif Original_Node (AV) /= AV then
9572 -- In Ada 2012, the explicit dereference may be a rewritten call to a
9573 -- Reference function.
9575 if Ada_Version >= Ada_2012
9576 and then Nkind (Original_Node (AV)) = N_Function_Call
9577 and then
9578 Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
9579 then
9580 return True;
9582 else
9583 return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
9584 end if;
9586 -- All other non-variables are rejected
9588 else
9589 return False;
9590 end if;
9591 end Is_OK_Variable_For_Out_Formal;
9593 -----------------------------------
9594 -- Is_Partially_Initialized_Type --
9595 -----------------------------------
9597 function Is_Partially_Initialized_Type
9598 (Typ : Entity_Id;
9599 Include_Implicit : Boolean := True) return Boolean
9601 begin
9602 if Is_Scalar_Type (Typ) then
9603 return False;
9605 elsif Is_Access_Type (Typ) then
9606 return Include_Implicit;
9608 elsif Is_Array_Type (Typ) then
9610 -- If component type is partially initialized, so is array type
9612 if Is_Partially_Initialized_Type
9613 (Component_Type (Typ), Include_Implicit)
9614 then
9615 return True;
9617 -- Otherwise we are only partially initialized if we are fully
9618 -- initialized (this is the empty array case, no point in us
9619 -- duplicating that code here).
9621 else
9622 return Is_Fully_Initialized_Type (Typ);
9623 end if;
9625 elsif Is_Record_Type (Typ) then
9627 -- A discriminated type is always partially initialized if in
9628 -- all mode
9630 if Has_Discriminants (Typ) and then Include_Implicit then
9631 return True;
9633 -- A tagged type is always partially initialized
9635 elsif Is_Tagged_Type (Typ) then
9636 return True;
9638 -- Case of non-discriminated record
9640 else
9641 declare
9642 Ent : Entity_Id;
9644 Component_Present : Boolean := False;
9645 -- Set True if at least one component is present. If no
9646 -- components are present, then record type is fully
9647 -- initialized (another odd case, like the null array).
9649 begin
9650 -- Loop through components
9652 Ent := First_Entity (Typ);
9653 while Present (Ent) loop
9654 if Ekind (Ent) = E_Component then
9655 Component_Present := True;
9657 -- If a component has an initialization expression then
9658 -- the enclosing record type is partially initialized
9660 if Present (Parent (Ent))
9661 and then Present (Expression (Parent (Ent)))
9662 then
9663 return True;
9665 -- If a component is of a type which is itself partially
9666 -- initialized, then the enclosing record type is also.
9668 elsif Is_Partially_Initialized_Type
9669 (Etype (Ent), Include_Implicit)
9670 then
9671 return True;
9672 end if;
9673 end if;
9675 Next_Entity (Ent);
9676 end loop;
9678 -- No initialized components found. If we found any components
9679 -- they were all uninitialized so the result is false.
9681 if Component_Present then
9682 return False;
9684 -- But if we found no components, then all the components are
9685 -- initialized so we consider the type to be initialized.
9687 else
9688 return True;
9689 end if;
9690 end;
9691 end if;
9693 -- Concurrent types are always fully initialized
9695 elsif Is_Concurrent_Type (Typ) then
9696 return True;
9698 -- For a private type, go to underlying type. If there is no underlying
9699 -- type then just assume this partially initialized. Not clear if this
9700 -- can happen in a non-error case, but no harm in testing for this.
9702 elsif Is_Private_Type (Typ) then
9703 declare
9704 U : constant Entity_Id := Underlying_Type (Typ);
9705 begin
9706 if No (U) then
9707 return True;
9708 else
9709 return Is_Partially_Initialized_Type (U, Include_Implicit);
9710 end if;
9711 end;
9713 -- For any other type (are there any?) assume partially initialized
9715 else
9716 return True;
9717 end if;
9718 end Is_Partially_Initialized_Type;
9720 ------------------------------------
9721 -- Is_Potentially_Persistent_Type --
9722 ------------------------------------
9724 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
9725 Comp : Entity_Id;
9726 Indx : Node_Id;
9728 begin
9729 -- For private type, test corresponding full type
9731 if Is_Private_Type (T) then
9732 return Is_Potentially_Persistent_Type (Full_View (T));
9734 -- Scalar types are potentially persistent
9736 elsif Is_Scalar_Type (T) then
9737 return True;
9739 -- Record type is potentially persistent if not tagged and the types of
9740 -- all it components are potentially persistent, and no component has
9741 -- an initialization expression.
9743 elsif Is_Record_Type (T)
9744 and then not Is_Tagged_Type (T)
9745 and then not Is_Partially_Initialized_Type (T)
9746 then
9747 Comp := First_Component (T);
9748 while Present (Comp) loop
9749 if not Is_Potentially_Persistent_Type (Etype (Comp)) then
9750 return False;
9751 else
9752 Next_Entity (Comp);
9753 end if;
9754 end loop;
9756 return True;
9758 -- Array type is potentially persistent if its component type is
9759 -- potentially persistent and if all its constraints are static.
9761 elsif Is_Array_Type (T) then
9762 if not Is_Potentially_Persistent_Type (Component_Type (T)) then
9763 return False;
9764 end if;
9766 Indx := First_Index (T);
9767 while Present (Indx) loop
9768 if not Is_OK_Static_Subtype (Etype (Indx)) then
9769 return False;
9770 else
9771 Next_Index (Indx);
9772 end if;
9773 end loop;
9775 return True;
9777 -- All other types are not potentially persistent
9779 else
9780 return False;
9781 end if;
9782 end Is_Potentially_Persistent_Type;
9784 ---------------------------------
9785 -- Is_Protected_Self_Reference --
9786 ---------------------------------
9788 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
9790 function In_Access_Definition (N : Node_Id) return Boolean;
9791 -- Returns true if N belongs to an access definition
9793 --------------------------
9794 -- In_Access_Definition --
9795 --------------------------
9797 function In_Access_Definition (N : Node_Id) return Boolean is
9798 P : Node_Id;
9800 begin
9801 P := Parent (N);
9802 while Present (P) loop
9803 if Nkind (P) = N_Access_Definition then
9804 return True;
9805 end if;
9807 P := Parent (P);
9808 end loop;
9810 return False;
9811 end In_Access_Definition;
9813 -- Start of processing for Is_Protected_Self_Reference
9815 begin
9816 -- Verify that prefix is analyzed and has the proper form. Note that
9817 -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address,
9818 -- which also produce the address of an entity, do not analyze their
9819 -- prefix because they denote entities that are not necessarily visible.
9820 -- Neither of them can apply to a protected type.
9822 return Ada_Version >= Ada_2005
9823 and then Is_Entity_Name (N)
9824 and then Present (Entity (N))
9825 and then Is_Protected_Type (Entity (N))
9826 and then In_Open_Scopes (Entity (N))
9827 and then not In_Access_Definition (N);
9828 end Is_Protected_Self_Reference;
9830 -----------------------------
9831 -- Is_RCI_Pkg_Spec_Or_Body --
9832 -----------------------------
9834 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
9836 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
9837 -- Return True if the unit of Cunit is an RCI package declaration
9839 ---------------------------
9840 -- Is_RCI_Pkg_Decl_Cunit --
9841 ---------------------------
9843 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
9844 The_Unit : constant Node_Id := Unit (Cunit);
9846 begin
9847 if Nkind (The_Unit) /= N_Package_Declaration then
9848 return False;
9849 end if;
9851 return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
9852 end Is_RCI_Pkg_Decl_Cunit;
9854 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
9856 begin
9857 return Is_RCI_Pkg_Decl_Cunit (Cunit)
9858 or else
9859 (Nkind (Unit (Cunit)) = N_Package_Body
9860 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
9861 end Is_RCI_Pkg_Spec_Or_Body;
9863 -----------------------------------------
9864 -- Is_Remote_Access_To_Class_Wide_Type --
9865 -----------------------------------------
9867 function Is_Remote_Access_To_Class_Wide_Type
9868 (E : Entity_Id) return Boolean
9870 begin
9871 -- A remote access to class-wide type is a general access to object type
9872 -- declared in the visible part of a Remote_Types or Remote_Call_
9873 -- Interface unit.
9875 return Ekind (E) = E_General_Access_Type
9876 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
9877 end Is_Remote_Access_To_Class_Wide_Type;
9879 -----------------------------------------
9880 -- Is_Remote_Access_To_Subprogram_Type --
9881 -----------------------------------------
9883 function Is_Remote_Access_To_Subprogram_Type
9884 (E : Entity_Id) return Boolean
9886 begin
9887 return (Ekind (E) = E_Access_Subprogram_Type
9888 or else (Ekind (E) = E_Record_Type
9889 and then Present (Corresponding_Remote_Type (E))))
9890 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
9891 end Is_Remote_Access_To_Subprogram_Type;
9893 --------------------
9894 -- Is_Remote_Call --
9895 --------------------
9897 function Is_Remote_Call (N : Node_Id) return Boolean is
9898 begin
9899 if Nkind (N) not in N_Subprogram_Call then
9901 -- An entry call cannot be remote
9903 return False;
9905 elsif Nkind (Name (N)) in N_Has_Entity
9906 and then Is_Remote_Call_Interface (Entity (Name (N)))
9907 then
9908 -- A subprogram declared in the spec of a RCI package is remote
9910 return True;
9912 elsif Nkind (Name (N)) = N_Explicit_Dereference
9913 and then Is_Remote_Access_To_Subprogram_Type
9914 (Etype (Prefix (Name (N))))
9915 then
9916 -- The dereference of a RAS is a remote call
9918 return True;
9920 elsif Present (Controlling_Argument (N))
9921 and then Is_Remote_Access_To_Class_Wide_Type
9922 (Etype (Controlling_Argument (N)))
9923 then
9924 -- Any primitive operation call with a controlling argument of
9925 -- a RACW type is a remote call.
9927 return True;
9928 end if;
9930 -- All other calls are local calls
9932 return False;
9933 end Is_Remote_Call;
9935 ----------------------
9936 -- Is_Renamed_Entry --
9937 ----------------------
9939 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
9940 Orig_Node : Node_Id := Empty;
9941 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
9943 function Is_Entry (Nam : Node_Id) return Boolean;
9944 -- Determine whether Nam is an entry. Traverse selectors if there are
9945 -- nested selected components.
9947 --------------
9948 -- Is_Entry --
9949 --------------
9951 function Is_Entry (Nam : Node_Id) return Boolean is
9952 begin
9953 if Nkind (Nam) = N_Selected_Component then
9954 return Is_Entry (Selector_Name (Nam));
9955 end if;
9957 return Ekind (Entity (Nam)) = E_Entry;
9958 end Is_Entry;
9960 -- Start of processing for Is_Renamed_Entry
9962 begin
9963 if Present (Alias (Proc_Nam)) then
9964 Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
9965 end if;
9967 -- Look for a rewritten subprogram renaming declaration
9969 if Nkind (Subp_Decl) = N_Subprogram_Declaration
9970 and then Present (Original_Node (Subp_Decl))
9971 then
9972 Orig_Node := Original_Node (Subp_Decl);
9973 end if;
9975 -- The rewritten subprogram is actually an entry
9977 if Present (Orig_Node)
9978 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
9979 and then Is_Entry (Name (Orig_Node))
9980 then
9981 return True;
9982 end if;
9984 return False;
9985 end Is_Renamed_Entry;
9987 ----------------------------
9988 -- Is_Reversible_Iterator --
9989 ----------------------------
9991 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
9992 Ifaces_List : Elist_Id;
9993 Iface_Elmt : Elmt_Id;
9994 Iface : Entity_Id;
9996 begin
9997 if Is_Class_Wide_Type (Typ)
9998 and then Chars (Etype (Typ)) = Name_Reversible_Iterator
9999 and then
10000 Is_Predefined_File_Name
10001 (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
10002 then
10003 return True;
10005 elsif not Is_Tagged_Type (Typ)
10006 or else not Is_Derived_Type (Typ)
10007 then
10008 return False;
10010 else
10011 Collect_Interfaces (Typ, Ifaces_List);
10013 Iface_Elmt := First_Elmt (Ifaces_List);
10014 while Present (Iface_Elmt) loop
10015 Iface := Node (Iface_Elmt);
10016 if Chars (Iface) = Name_Reversible_Iterator
10017 and then
10018 Is_Predefined_File_Name
10019 (Unit_File_Name (Get_Source_Unit (Iface)))
10020 then
10021 return True;
10022 end if;
10024 Next_Elmt (Iface_Elmt);
10025 end loop;
10026 end if;
10028 return False;
10029 end Is_Reversible_Iterator;
10031 ----------------------
10032 -- Is_Selector_Name --
10033 ----------------------
10035 function Is_Selector_Name (N : Node_Id) return Boolean is
10036 begin
10037 if not Is_List_Member (N) then
10038 declare
10039 P : constant Node_Id := Parent (N);
10040 K : constant Node_Kind := Nkind (P);
10041 begin
10042 return
10043 (K = N_Expanded_Name or else
10044 K = N_Generic_Association or else
10045 K = N_Parameter_Association or else
10046 K = N_Selected_Component)
10047 and then Selector_Name (P) = N;
10048 end;
10050 else
10051 declare
10052 L : constant List_Id := List_Containing (N);
10053 P : constant Node_Id := Parent (L);
10054 begin
10055 return (Nkind (P) = N_Discriminant_Association
10056 and then Selector_Names (P) = L)
10057 or else
10058 (Nkind (P) = N_Component_Association
10059 and then Choices (P) = L);
10060 end;
10061 end if;
10062 end Is_Selector_Name;
10064 ----------------------------------
10065 -- Is_SPARK_Initialization_Expr --
10066 ----------------------------------
10068 function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
10069 Is_Ok : Boolean;
10070 Expr : Node_Id;
10071 Comp_Assn : Node_Id;
10072 Orig_N : constant Node_Id := Original_Node (N);
10074 begin
10075 Is_Ok := True;
10077 if not Comes_From_Source (Orig_N) then
10078 goto Done;
10079 end if;
10081 pragma Assert (Nkind (Orig_N) in N_Subexpr);
10083 case Nkind (Orig_N) is
10084 when N_Character_Literal |
10085 N_Integer_Literal |
10086 N_Real_Literal |
10087 N_String_Literal =>
10088 null;
10090 when N_Identifier |
10091 N_Expanded_Name =>
10092 if Is_Entity_Name (Orig_N)
10093 and then Present (Entity (Orig_N)) -- needed in some cases
10094 then
10095 case Ekind (Entity (Orig_N)) is
10096 when E_Constant |
10097 E_Enumeration_Literal |
10098 E_Named_Integer |
10099 E_Named_Real =>
10100 null;
10101 when others =>
10102 if Is_Type (Entity (Orig_N)) then
10103 null;
10104 else
10105 Is_Ok := False;
10106 end if;
10107 end case;
10108 end if;
10110 when N_Qualified_Expression |
10111 N_Type_Conversion =>
10112 Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N));
10114 when N_Unary_Op =>
10115 Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
10117 when N_Binary_Op |
10118 N_Short_Circuit |
10119 N_Membership_Test =>
10120 Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
10121 and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
10123 when N_Aggregate |
10124 N_Extension_Aggregate =>
10125 if Nkind (Orig_N) = N_Extension_Aggregate then
10126 Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N));
10127 end if;
10129 Expr := First (Expressions (Orig_N));
10130 while Present (Expr) loop
10131 if not Is_SPARK_Initialization_Expr (Expr) then
10132 Is_Ok := False;
10133 goto Done;
10134 end if;
10136 Next (Expr);
10137 end loop;
10139 Comp_Assn := First (Component_Associations (Orig_N));
10140 while Present (Comp_Assn) loop
10141 Expr := Expression (Comp_Assn);
10142 if Present (Expr) -- needed for box association
10143 and then not Is_SPARK_Initialization_Expr (Expr)
10144 then
10145 Is_Ok := False;
10146 goto Done;
10147 end if;
10149 Next (Comp_Assn);
10150 end loop;
10152 when N_Attribute_Reference =>
10153 if Nkind (Prefix (Orig_N)) in N_Subexpr then
10154 Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N));
10155 end if;
10157 Expr := First (Expressions (Orig_N));
10158 while Present (Expr) loop
10159 if not Is_SPARK_Initialization_Expr (Expr) then
10160 Is_Ok := False;
10161 goto Done;
10162 end if;
10164 Next (Expr);
10165 end loop;
10167 -- Selected components might be expanded named not yet resolved, so
10168 -- default on the safe side. (Eg on sparklex.ads)
10170 when N_Selected_Component =>
10171 null;
10173 when others =>
10174 Is_Ok := False;
10175 end case;
10177 <<Done>>
10178 return Is_Ok;
10179 end Is_SPARK_Initialization_Expr;
10181 -------------------------------
10182 -- Is_SPARK_Object_Reference --
10183 -------------------------------
10185 function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
10186 begin
10187 if Is_Entity_Name (N) then
10188 return Present (Entity (N))
10189 and then
10190 (Ekind_In (Entity (N), E_Constant, E_Variable)
10191 or else Ekind (Entity (N)) in Formal_Kind);
10193 else
10194 case Nkind (N) is
10195 when N_Selected_Component =>
10196 return Is_SPARK_Object_Reference (Prefix (N));
10198 when others =>
10199 return False;
10200 end case;
10201 end if;
10202 end Is_SPARK_Object_Reference;
10204 ------------------
10205 -- Is_Statement --
10206 ------------------
10208 function Is_Statement (N : Node_Id) return Boolean is
10209 begin
10210 return
10211 Nkind (N) in N_Statement_Other_Than_Procedure_Call
10212 or else Nkind (N) = N_Procedure_Call_Statement;
10213 end Is_Statement;
10215 --------------------------------------------------
10216 -- Is_Subprogram_Stub_Without_Prior_Declaration --
10217 --------------------------------------------------
10219 function Is_Subprogram_Stub_Without_Prior_Declaration
10220 (N : Node_Id) return Boolean
10222 begin
10223 -- A subprogram stub without prior declaration serves as declaration for
10224 -- the actual subprogram body. As such, it has an attached defining
10225 -- entity of E_[Generic_]Function or E_[Generic_]Procedure.
10227 return Nkind (N) = N_Subprogram_Body_Stub
10228 and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
10229 end Is_Subprogram_Stub_Without_Prior_Declaration;
10231 ---------------------------------
10232 -- Is_Synchronized_Tagged_Type --
10233 ---------------------------------
10235 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
10236 Kind : constant Entity_Kind := Ekind (Base_Type (E));
10238 begin
10239 -- A task or protected type derived from an interface is a tagged type.
10240 -- Such a tagged type is called a synchronized tagged type, as are
10241 -- synchronized interfaces and private extensions whose declaration
10242 -- includes the reserved word synchronized.
10244 return (Is_Tagged_Type (E)
10245 and then (Kind = E_Task_Type
10246 or else Kind = E_Protected_Type))
10247 or else
10248 (Is_Interface (E)
10249 and then Is_Synchronized_Interface (E))
10250 or else
10251 (Ekind (E) = E_Record_Type_With_Private
10252 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
10253 and then (Synchronized_Present (Parent (E))
10254 or else Is_Synchronized_Interface (Etype (E))));
10255 end Is_Synchronized_Tagged_Type;
10257 -----------------
10258 -- Is_Transfer --
10259 -----------------
10261 function Is_Transfer (N : Node_Id) return Boolean is
10262 Kind : constant Node_Kind := Nkind (N);
10264 begin
10265 if Kind = N_Simple_Return_Statement
10266 or else
10267 Kind = N_Extended_Return_Statement
10268 or else
10269 Kind = N_Goto_Statement
10270 or else
10271 Kind = N_Raise_Statement
10272 or else
10273 Kind = N_Requeue_Statement
10274 then
10275 return True;
10277 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
10278 and then No (Condition (N))
10279 then
10280 return True;
10282 elsif Kind = N_Procedure_Call_Statement
10283 and then Is_Entity_Name (Name (N))
10284 and then Present (Entity (Name (N)))
10285 and then No_Return (Entity (Name (N)))
10286 then
10287 return True;
10289 elsif Nkind (Original_Node (N)) = N_Raise_Statement then
10290 return True;
10292 else
10293 return False;
10294 end if;
10295 end Is_Transfer;
10297 -------------
10298 -- Is_True --
10299 -------------
10301 function Is_True (U : Uint) return Boolean is
10302 begin
10303 return (U /= 0);
10304 end Is_True;
10306 -------------------------------
10307 -- Is_Universal_Numeric_Type --
10308 -------------------------------
10310 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
10311 begin
10312 return T = Universal_Integer or else T = Universal_Real;
10313 end Is_Universal_Numeric_Type;
10315 -------------------
10316 -- Is_Value_Type --
10317 -------------------
10319 function Is_Value_Type (T : Entity_Id) return Boolean is
10320 begin
10321 return VM_Target = CLI_Target
10322 and then Nkind (T) in N_Has_Chars
10323 and then Chars (T) /= No_Name
10324 and then Get_Name_String (Chars (T)) = "valuetype";
10325 end Is_Value_Type;
10327 ----------------------------
10328 -- Is_Variable_Size_Array --
10329 ----------------------------
10331 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
10332 Idx : Node_Id;
10334 begin
10335 pragma Assert (Is_Array_Type (E));
10337 -- Check if some index is initialized with a non-constant value
10339 Idx := First_Index (E);
10340 while Present (Idx) loop
10341 if Nkind (Idx) = N_Range then
10342 if not Is_Constant_Bound (Low_Bound (Idx))
10343 or else not Is_Constant_Bound (High_Bound (Idx))
10344 then
10345 return True;
10346 end if;
10347 end if;
10349 Idx := Next_Index (Idx);
10350 end loop;
10352 return False;
10353 end Is_Variable_Size_Array;
10355 -----------------------------
10356 -- Is_Variable_Size_Record --
10357 -----------------------------
10359 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
10360 Comp : Entity_Id;
10361 Comp_Typ : Entity_Id;
10363 begin
10364 pragma Assert (Is_Record_Type (E));
10366 Comp := First_Entity (E);
10367 while Present (Comp) loop
10368 Comp_Typ := Etype (Comp);
10370 -- Recursive call if the record type has discriminants
10372 if Is_Record_Type (Comp_Typ)
10373 and then Has_Discriminants (Comp_Typ)
10374 and then Is_Variable_Size_Record (Comp_Typ)
10375 then
10376 return True;
10378 elsif Is_Array_Type (Comp_Typ)
10379 and then Is_Variable_Size_Array (Comp_Typ)
10380 then
10381 return True;
10382 end if;
10384 Next_Entity (Comp);
10385 end loop;
10387 return False;
10388 end Is_Variable_Size_Record;
10390 ---------------------
10391 -- Is_VMS_Operator --
10392 ---------------------
10394 function Is_VMS_Operator (Op : Entity_Id) return Boolean is
10395 begin
10396 -- The VMS operators are declared in a child of System that is loaded
10397 -- through pragma Extend_System. In some rare cases a program is run
10398 -- with this extension but without indicating that the target is VMS.
10400 return Ekind (Op) = E_Function
10401 and then Is_Intrinsic_Subprogram (Op)
10402 and then
10403 ((Present_System_Aux and then Scope (Op) = System_Aux_Id)
10404 or else
10405 (True_VMS_Target
10406 and then Scope (Scope (Op)) = RTU_Entity (System)));
10407 end Is_VMS_Operator;
10409 -----------------
10410 -- Is_Variable --
10411 -----------------
10413 function Is_Variable
10414 (N : Node_Id;
10415 Use_Original_Node : Boolean := True) return Boolean
10417 Orig_Node : Node_Id;
10419 function In_Protected_Function (E : Entity_Id) return Boolean;
10420 -- Within a protected function, the private components of the enclosing
10421 -- protected type are constants. A function nested within a (protected)
10422 -- procedure is not itself protected. Within the body of a protected
10423 -- function the current instance of the protected type is a constant.
10425 function Is_Variable_Prefix (P : Node_Id) return Boolean;
10426 -- Prefixes can involve implicit dereferences, in which case we must
10427 -- test for the case of a reference of a constant access type, which can
10428 -- can never be a variable.
10430 ---------------------------
10431 -- In_Protected_Function --
10432 ---------------------------
10434 function In_Protected_Function (E : Entity_Id) return Boolean is
10435 Prot : Entity_Id;
10436 S : Entity_Id;
10438 begin
10439 -- E is the current instance of a type
10441 if Is_Type (E) then
10442 Prot := E;
10444 -- E is an object
10446 else
10447 Prot := Scope (E);
10448 end if;
10450 if not Is_Protected_Type (Prot) then
10451 return False;
10453 else
10454 S := Current_Scope;
10455 while Present (S) and then S /= Prot loop
10456 if Ekind (S) = E_Function and then Scope (S) = Prot then
10457 return True;
10458 end if;
10460 S := Scope (S);
10461 end loop;
10463 return False;
10464 end if;
10465 end In_Protected_Function;
10467 ------------------------
10468 -- Is_Variable_Prefix --
10469 ------------------------
10471 function Is_Variable_Prefix (P : Node_Id) return Boolean is
10472 begin
10473 if Is_Access_Type (Etype (P)) then
10474 return not Is_Access_Constant (Root_Type (Etype (P)));
10476 -- For the case of an indexed component whose prefix has a packed
10477 -- array type, the prefix has been rewritten into a type conversion.
10478 -- Determine variable-ness from the converted expression.
10480 elsif Nkind (P) = N_Type_Conversion
10481 and then not Comes_From_Source (P)
10482 and then Is_Array_Type (Etype (P))
10483 and then Is_Packed (Etype (P))
10484 then
10485 return Is_Variable (Expression (P));
10487 else
10488 return Is_Variable (P);
10489 end if;
10490 end Is_Variable_Prefix;
10492 -- Start of processing for Is_Variable
10494 begin
10495 -- Check if we perform the test on the original node since this may be a
10496 -- test of syntactic categories which must not be disturbed by whatever
10497 -- rewriting might have occurred. For example, an aggregate, which is
10498 -- certainly NOT a variable, could be turned into a variable by
10499 -- expansion.
10501 if Use_Original_Node then
10502 Orig_Node := Original_Node (N);
10503 else
10504 Orig_Node := N;
10505 end if;
10507 -- Definitely OK if Assignment_OK is set. Since this is something that
10508 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
10510 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
10511 return True;
10513 -- Normally we go to the original node, but there is one exception where
10514 -- we use the rewritten node, namely when it is an explicit dereference.
10515 -- The generated code may rewrite a prefix which is an access type with
10516 -- an explicit dereference. The dereference is a variable, even though
10517 -- the original node may not be (since it could be a constant of the
10518 -- access type).
10520 -- In Ada 2005 we have a further case to consider: the prefix may be a
10521 -- function call given in prefix notation. The original node appears to
10522 -- be a selected component, but we need to examine the call.
10524 elsif Nkind (N) = N_Explicit_Dereference
10525 and then Nkind (Orig_Node) /= N_Explicit_Dereference
10526 and then Present (Etype (Orig_Node))
10527 and then Is_Access_Type (Etype (Orig_Node))
10528 then
10529 -- Note that if the prefix is an explicit dereference that does not
10530 -- come from source, we must check for a rewritten function call in
10531 -- prefixed notation before other forms of rewriting, to prevent a
10532 -- compiler crash.
10534 return
10535 (Nkind (Orig_Node) = N_Function_Call
10536 and then not Is_Access_Constant (Etype (Prefix (N))))
10537 or else
10538 Is_Variable_Prefix (Original_Node (Prefix (N)));
10540 -- in Ada 2012, the dereference may have been added for a type with
10541 -- a declared implicit dereference aspect.
10543 elsif Nkind (N) = N_Explicit_Dereference
10544 and then Present (Etype (Orig_Node))
10545 and then Ada_Version >= Ada_2012
10546 and then Has_Implicit_Dereference (Etype (Orig_Node))
10547 then
10548 return True;
10550 -- A function call is never a variable
10552 elsif Nkind (N) = N_Function_Call then
10553 return False;
10555 -- All remaining checks use the original node
10557 elsif Is_Entity_Name (Orig_Node)
10558 and then Present (Entity (Orig_Node))
10559 then
10560 declare
10561 E : constant Entity_Id := Entity (Orig_Node);
10562 K : constant Entity_Kind := Ekind (E);
10564 begin
10565 return (K = E_Variable
10566 and then Nkind (Parent (E)) /= N_Exception_Handler)
10567 or else (K = E_Component
10568 and then not In_Protected_Function (E))
10569 or else K = E_Out_Parameter
10570 or else K = E_In_Out_Parameter
10571 or else K = E_Generic_In_Out_Parameter
10573 -- Current instance of type. If this is a protected type, check
10574 -- we are not within the body of one of its protected functions.
10576 or else (Is_Type (E)
10577 and then In_Open_Scopes (E)
10578 and then not In_Protected_Function (E))
10580 or else (Is_Incomplete_Or_Private_Type (E)
10581 and then In_Open_Scopes (Full_View (E)));
10582 end;
10584 else
10585 case Nkind (Orig_Node) is
10586 when N_Indexed_Component | N_Slice =>
10587 return Is_Variable_Prefix (Prefix (Orig_Node));
10589 when N_Selected_Component =>
10590 return Is_Variable_Prefix (Prefix (Orig_Node))
10591 and then Is_Variable (Selector_Name (Orig_Node));
10593 -- For an explicit dereference, the type of the prefix cannot
10594 -- be an access to constant or an access to subprogram.
10596 when N_Explicit_Dereference =>
10597 declare
10598 Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
10599 begin
10600 return Is_Access_Type (Typ)
10601 and then not Is_Access_Constant (Root_Type (Typ))
10602 and then Ekind (Typ) /= E_Access_Subprogram_Type;
10603 end;
10605 -- The type conversion is the case where we do not deal with the
10606 -- context dependent special case of an actual parameter. Thus
10607 -- the type conversion is only considered a variable for the
10608 -- purposes of this routine if the target type is tagged. However,
10609 -- a type conversion is considered to be a variable if it does not
10610 -- come from source (this deals for example with the conversions
10611 -- of expressions to their actual subtypes).
10613 when N_Type_Conversion =>
10614 return Is_Variable (Expression (Orig_Node))
10615 and then
10616 (not Comes_From_Source (Orig_Node)
10617 or else
10618 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
10619 and then
10620 Is_Tagged_Type (Etype (Expression (Orig_Node)))));
10622 -- GNAT allows an unchecked type conversion as a variable. This
10623 -- only affects the generation of internal expanded code, since
10624 -- calls to instantiations of Unchecked_Conversion are never
10625 -- considered variables (since they are function calls).
10627 when N_Unchecked_Type_Conversion =>
10628 return Is_Variable (Expression (Orig_Node));
10630 when others =>
10631 return False;
10632 end case;
10633 end if;
10634 end Is_Variable;
10636 ---------------------------
10637 -- Is_Visibly_Controlled --
10638 ---------------------------
10640 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
10641 Root : constant Entity_Id := Root_Type (T);
10642 begin
10643 return Chars (Scope (Root)) = Name_Finalization
10644 and then Chars (Scope (Scope (Root))) = Name_Ada
10645 and then Scope (Scope (Scope (Root))) = Standard_Standard;
10646 end Is_Visibly_Controlled;
10648 ------------------------
10649 -- Is_Volatile_Object --
10650 ------------------------
10652 function Is_Volatile_Object (N : Node_Id) return Boolean is
10654 function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
10655 -- Determines if given object has volatile components
10657 function Is_Volatile_Prefix (N : Node_Id) return Boolean;
10658 -- If prefix is an implicit dereference, examine designated type
10660 ------------------------
10661 -- Is_Volatile_Prefix --
10662 ------------------------
10664 function Is_Volatile_Prefix (N : Node_Id) return Boolean is
10665 Typ : constant Entity_Id := Etype (N);
10667 begin
10668 if Is_Access_Type (Typ) then
10669 declare
10670 Dtyp : constant Entity_Id := Designated_Type (Typ);
10672 begin
10673 return Is_Volatile (Dtyp)
10674 or else Has_Volatile_Components (Dtyp);
10675 end;
10677 else
10678 return Object_Has_Volatile_Components (N);
10679 end if;
10680 end Is_Volatile_Prefix;
10682 ------------------------------------
10683 -- Object_Has_Volatile_Components --
10684 ------------------------------------
10686 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
10687 Typ : constant Entity_Id := Etype (N);
10689 begin
10690 if Is_Volatile (Typ)
10691 or else Has_Volatile_Components (Typ)
10692 then
10693 return True;
10695 elsif Is_Entity_Name (N)
10696 and then (Has_Volatile_Components (Entity (N))
10697 or else Is_Volatile (Entity (N)))
10698 then
10699 return True;
10701 elsif Nkind (N) = N_Indexed_Component
10702 or else Nkind (N) = N_Selected_Component
10703 then
10704 return Is_Volatile_Prefix (Prefix (N));
10706 else
10707 return False;
10708 end if;
10709 end Object_Has_Volatile_Components;
10711 -- Start of processing for Is_Volatile_Object
10713 begin
10714 if Is_Volatile (Etype (N))
10715 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
10716 then
10717 return True;
10719 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
10720 and then Is_Volatile_Prefix (Prefix (N))
10721 then
10722 return True;
10724 elsif Nkind (N) = N_Selected_Component
10725 and then Is_Volatile (Entity (Selector_Name (N)))
10726 then
10727 return True;
10729 else
10730 return False;
10731 end if;
10732 end Is_Volatile_Object;
10734 ---------------------------
10735 -- Itype_Has_Declaration --
10736 ---------------------------
10738 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
10739 begin
10740 pragma Assert (Is_Itype (Id));
10741 return Present (Parent (Id))
10742 and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
10743 N_Subtype_Declaration)
10744 and then Defining_Entity (Parent (Id)) = Id;
10745 end Itype_Has_Declaration;
10747 -------------------------
10748 -- Kill_Current_Values --
10749 -------------------------
10751 procedure Kill_Current_Values
10752 (Ent : Entity_Id;
10753 Last_Assignment_Only : Boolean := False)
10755 begin
10756 -- ??? do we have to worry about clearing cached checks?
10758 if Is_Assignable (Ent) then
10759 Set_Last_Assignment (Ent, Empty);
10760 end if;
10762 if Is_Object (Ent) then
10763 if not Last_Assignment_Only then
10764 Kill_Checks (Ent);
10765 Set_Current_Value (Ent, Empty);
10767 if not Can_Never_Be_Null (Ent) then
10768 Set_Is_Known_Non_Null (Ent, False);
10769 end if;
10771 Set_Is_Known_Null (Ent, False);
10773 -- Reset Is_Known_Valid unless type is always valid, or if we have
10774 -- a loop parameter (loop parameters are always valid, since their
10775 -- bounds are defined by the bounds given in the loop header).
10777 if not Is_Known_Valid (Etype (Ent))
10778 and then Ekind (Ent) /= E_Loop_Parameter
10779 then
10780 Set_Is_Known_Valid (Ent, False);
10781 end if;
10782 end if;
10783 end if;
10784 end Kill_Current_Values;
10786 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
10787 S : Entity_Id;
10789 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
10790 -- Clear current value for entity E and all entities chained to E
10792 ------------------------------------------
10793 -- Kill_Current_Values_For_Entity_Chain --
10794 ------------------------------------------
10796 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
10797 Ent : Entity_Id;
10798 begin
10799 Ent := E;
10800 while Present (Ent) loop
10801 Kill_Current_Values (Ent, Last_Assignment_Only);
10802 Next_Entity (Ent);
10803 end loop;
10804 end Kill_Current_Values_For_Entity_Chain;
10806 -- Start of processing for Kill_Current_Values
10808 begin
10809 -- Kill all saved checks, a special case of killing saved values
10811 if not Last_Assignment_Only then
10812 Kill_All_Checks;
10813 end if;
10815 -- Loop through relevant scopes, which includes the current scope and
10816 -- any parent scopes if the current scope is a block or a package.
10818 S := Current_Scope;
10819 Scope_Loop : loop
10821 -- Clear current values of all entities in current scope
10823 Kill_Current_Values_For_Entity_Chain (First_Entity (S));
10825 -- If scope is a package, also clear current values of all private
10826 -- entities in the scope.
10828 if Is_Package_Or_Generic_Package (S)
10829 or else Is_Concurrent_Type (S)
10830 then
10831 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
10832 end if;
10834 -- If this is a not a subprogram, deal with parents
10836 if not Is_Subprogram (S) then
10837 S := Scope (S);
10838 exit Scope_Loop when S = Standard_Standard;
10839 else
10840 exit Scope_Loop;
10841 end if;
10842 end loop Scope_Loop;
10843 end Kill_Current_Values;
10845 --------------------------
10846 -- Kill_Size_Check_Code --
10847 --------------------------
10849 procedure Kill_Size_Check_Code (E : Entity_Id) is
10850 begin
10851 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
10852 and then Present (Size_Check_Code (E))
10853 then
10854 Remove (Size_Check_Code (E));
10855 Set_Size_Check_Code (E, Empty);
10856 end if;
10857 end Kill_Size_Check_Code;
10859 --------------------------
10860 -- Known_To_Be_Assigned --
10861 --------------------------
10863 function Known_To_Be_Assigned (N : Node_Id) return Boolean is
10864 P : constant Node_Id := Parent (N);
10866 begin
10867 case Nkind (P) is
10869 -- Test left side of assignment
10871 when N_Assignment_Statement =>
10872 return N = Name (P);
10874 -- Function call arguments are never lvalues
10876 when N_Function_Call =>
10877 return False;
10879 -- Positional parameter for procedure or accept call
10881 when N_Procedure_Call_Statement |
10882 N_Accept_Statement
10884 declare
10885 Proc : Entity_Id;
10886 Form : Entity_Id;
10887 Act : Node_Id;
10889 begin
10890 Proc := Get_Subprogram_Entity (P);
10892 if No (Proc) then
10893 return False;
10894 end if;
10896 -- If we are not a list member, something is strange, so
10897 -- be conservative and return False.
10899 if not Is_List_Member (N) then
10900 return False;
10901 end if;
10903 -- We are going to find the right formal by stepping forward
10904 -- through the formals, as we step backwards in the actuals.
10906 Form := First_Formal (Proc);
10907 Act := N;
10908 loop
10909 -- If no formal, something is weird, so be conservative
10910 -- and return False.
10912 if No (Form) then
10913 return False;
10914 end if;
10916 Prev (Act);
10917 exit when No (Act);
10918 Next_Formal (Form);
10919 end loop;
10921 return Ekind (Form) /= E_In_Parameter;
10922 end;
10924 -- Named parameter for procedure or accept call
10926 when N_Parameter_Association =>
10927 declare
10928 Proc : Entity_Id;
10929 Form : Entity_Id;
10931 begin
10932 Proc := Get_Subprogram_Entity (Parent (P));
10934 if No (Proc) then
10935 return False;
10936 end if;
10938 -- Loop through formals to find the one that matches
10940 Form := First_Formal (Proc);
10941 loop
10942 -- If no matching formal, that's peculiar, some kind of
10943 -- previous error, so return False to be conservative.
10944 -- Actually this also happens in legal code in the case
10945 -- where P is a parameter association for an Extra_Formal???
10947 if No (Form) then
10948 return False;
10949 end if;
10951 -- Else test for match
10953 if Chars (Form) = Chars (Selector_Name (P)) then
10954 return Ekind (Form) /= E_In_Parameter;
10955 end if;
10957 Next_Formal (Form);
10958 end loop;
10959 end;
10961 -- Test for appearing in a conversion that itself appears
10962 -- in an lvalue context, since this should be an lvalue.
10964 when N_Type_Conversion =>
10965 return Known_To_Be_Assigned (P);
10967 -- All other references are definitely not known to be modifications
10969 when others =>
10970 return False;
10972 end case;
10973 end Known_To_Be_Assigned;
10975 ---------------------------
10976 -- Last_Source_Statement --
10977 ---------------------------
10979 function Last_Source_Statement (HSS : Node_Id) return Node_Id is
10980 N : Node_Id;
10982 begin
10983 N := Last (Statements (HSS));
10984 while Present (N) loop
10985 exit when Comes_From_Source (N);
10986 Prev (N);
10987 end loop;
10989 return N;
10990 end Last_Source_Statement;
10992 ----------------------------------
10993 -- Matching_Static_Array_Bounds --
10994 ----------------------------------
10996 function Matching_Static_Array_Bounds
10997 (L_Typ : Node_Id;
10998 R_Typ : Node_Id) return Boolean
11000 L_Ndims : constant Nat := Number_Dimensions (L_Typ);
11001 R_Ndims : constant Nat := Number_Dimensions (R_Typ);
11003 L_Index : Node_Id;
11004 R_Index : Node_Id;
11005 L_Low : Node_Id;
11006 L_High : Node_Id;
11007 L_Len : Uint;
11008 R_Low : Node_Id;
11009 R_High : Node_Id;
11010 R_Len : Uint;
11012 begin
11013 if L_Ndims /= R_Ndims then
11014 return False;
11015 end if;
11017 -- Unconstrained types do not have static bounds
11019 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
11020 return False;
11021 end if;
11023 -- First treat specially the first dimension, as the lower bound and
11024 -- length of string literals are not stored like those of arrays.
11026 if Ekind (L_Typ) = E_String_Literal_Subtype then
11027 L_Low := String_Literal_Low_Bound (L_Typ);
11028 L_Len := String_Literal_Length (L_Typ);
11029 else
11030 L_Index := First_Index (L_Typ);
11031 Get_Index_Bounds (L_Index, L_Low, L_High);
11033 if Is_OK_Static_Expression (L_Low)
11034 and then Is_OK_Static_Expression (L_High)
11035 then
11036 if Expr_Value (L_High) < Expr_Value (L_Low) then
11037 L_Len := Uint_0;
11038 else
11039 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
11040 end if;
11041 else
11042 return False;
11043 end if;
11044 end if;
11046 if Ekind (R_Typ) = E_String_Literal_Subtype then
11047 R_Low := String_Literal_Low_Bound (R_Typ);
11048 R_Len := String_Literal_Length (R_Typ);
11049 else
11050 R_Index := First_Index (R_Typ);
11051 Get_Index_Bounds (R_Index, R_Low, R_High);
11053 if Is_OK_Static_Expression (R_Low)
11054 and then Is_OK_Static_Expression (R_High)
11055 then
11056 if Expr_Value (R_High) < Expr_Value (R_Low) then
11057 R_Len := Uint_0;
11058 else
11059 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
11060 end if;
11061 else
11062 return False;
11063 end if;
11064 end if;
11066 if Is_OK_Static_Expression (L_Low)
11067 and then Is_OK_Static_Expression (R_Low)
11068 and then Expr_Value (L_Low) = Expr_Value (R_Low)
11069 and then L_Len = R_Len
11070 then
11071 null;
11072 else
11073 return False;
11074 end if;
11076 -- Then treat all other dimensions
11078 for Indx in 2 .. L_Ndims loop
11079 Next (L_Index);
11080 Next (R_Index);
11082 Get_Index_Bounds (L_Index, L_Low, L_High);
11083 Get_Index_Bounds (R_Index, R_Low, R_High);
11085 if Is_OK_Static_Expression (L_Low)
11086 and then Is_OK_Static_Expression (L_High)
11087 and then Is_OK_Static_Expression (R_Low)
11088 and then Is_OK_Static_Expression (R_High)
11089 and then Expr_Value (L_Low) = Expr_Value (R_Low)
11090 and then Expr_Value (L_High) = Expr_Value (R_High)
11091 then
11092 null;
11093 else
11094 return False;
11095 end if;
11096 end loop;
11098 -- If we fall through the loop, all indexes matched
11100 return True;
11101 end Matching_Static_Array_Bounds;
11103 -------------------
11104 -- May_Be_Lvalue --
11105 -------------------
11107 function May_Be_Lvalue (N : Node_Id) return Boolean is
11108 P : constant Node_Id := Parent (N);
11110 begin
11111 case Nkind (P) is
11113 -- Test left side of assignment
11115 when N_Assignment_Statement =>
11116 return N = Name (P);
11118 -- Test prefix of component or attribute. Note that the prefix of an
11119 -- explicit or implicit dereference cannot be an l-value.
11121 when N_Attribute_Reference =>
11122 return N = Prefix (P)
11123 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
11125 -- For an expanded name, the name is an lvalue if the expanded name
11126 -- is an lvalue, but the prefix is never an lvalue, since it is just
11127 -- the scope where the name is found.
11129 when N_Expanded_Name =>
11130 if N = Prefix (P) then
11131 return May_Be_Lvalue (P);
11132 else
11133 return False;
11134 end if;
11136 -- For a selected component A.B, A is certainly an lvalue if A.B is.
11137 -- B is a little interesting, if we have A.B := 3, there is some
11138 -- discussion as to whether B is an lvalue or not, we choose to say
11139 -- it is. Note however that A is not an lvalue if it is of an access
11140 -- type since this is an implicit dereference.
11142 when N_Selected_Component =>
11143 if N = Prefix (P)
11144 and then Present (Etype (N))
11145 and then Is_Access_Type (Etype (N))
11146 then
11147 return False;
11148 else
11149 return May_Be_Lvalue (P);
11150 end if;
11152 -- For an indexed component or slice, the index or slice bounds is
11153 -- never an lvalue. The prefix is an lvalue if the indexed component
11154 -- or slice is an lvalue, except if it is an access type, where we
11155 -- have an implicit dereference.
11157 when N_Indexed_Component | N_Slice =>
11158 if N /= Prefix (P)
11159 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
11160 then
11161 return False;
11162 else
11163 return May_Be_Lvalue (P);
11164 end if;
11166 -- Prefix of a reference is an lvalue if the reference is an lvalue
11168 when N_Reference =>
11169 return May_Be_Lvalue (P);
11171 -- Prefix of explicit dereference is never an lvalue
11173 when N_Explicit_Dereference =>
11174 return False;
11176 -- Positional parameter for subprogram, entry, or accept call.
11177 -- In older versions of Ada function call arguments are never
11178 -- lvalues. In Ada 2012 functions can have in-out parameters.
11180 when N_Subprogram_Call |
11181 N_Entry_Call_Statement |
11182 N_Accept_Statement
11184 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
11185 return False;
11186 end if;
11188 -- The following mechanism is clumsy and fragile. A single flag
11189 -- set in Resolve_Actuals would be preferable ???
11191 declare
11192 Proc : Entity_Id;
11193 Form : Entity_Id;
11194 Act : Node_Id;
11196 begin
11197 Proc := Get_Subprogram_Entity (P);
11199 if No (Proc) then
11200 return True;
11201 end if;
11203 -- If we are not a list member, something is strange, so be
11204 -- conservative and return True.
11206 if not Is_List_Member (N) then
11207 return True;
11208 end if;
11210 -- We are going to find the right formal by stepping forward
11211 -- through the formals, as we step backwards in the actuals.
11213 Form := First_Formal (Proc);
11214 Act := N;
11215 loop
11216 -- If no formal, something is weird, so be conservative and
11217 -- return True.
11219 if No (Form) then
11220 return True;
11221 end if;
11223 Prev (Act);
11224 exit when No (Act);
11225 Next_Formal (Form);
11226 end loop;
11228 return Ekind (Form) /= E_In_Parameter;
11229 end;
11231 -- Named parameter for procedure or accept call
11233 when N_Parameter_Association =>
11234 declare
11235 Proc : Entity_Id;
11236 Form : Entity_Id;
11238 begin
11239 Proc := Get_Subprogram_Entity (Parent (P));
11241 if No (Proc) then
11242 return True;
11243 end if;
11245 -- Loop through formals to find the one that matches
11247 Form := First_Formal (Proc);
11248 loop
11249 -- If no matching formal, that's peculiar, some kind of
11250 -- previous error, so return True to be conservative.
11251 -- Actually happens with legal code for an unresolved call
11252 -- where we may get the wrong homonym???
11254 if No (Form) then
11255 return True;
11256 end if;
11258 -- Else test for match
11260 if Chars (Form) = Chars (Selector_Name (P)) then
11261 return Ekind (Form) /= E_In_Parameter;
11262 end if;
11264 Next_Formal (Form);
11265 end loop;
11266 end;
11268 -- Test for appearing in a conversion that itself appears in an
11269 -- lvalue context, since this should be an lvalue.
11271 when N_Type_Conversion =>
11272 return May_Be_Lvalue (P);
11274 -- Test for appearance in object renaming declaration
11276 when N_Object_Renaming_Declaration =>
11277 return True;
11279 -- All other references are definitely not lvalues
11281 when others =>
11282 return False;
11284 end case;
11285 end May_Be_Lvalue;
11287 -----------------------
11288 -- Mark_Coextensions --
11289 -----------------------
11291 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
11292 Is_Dynamic : Boolean;
11293 -- Indicates whether the context causes nested coextensions to be
11294 -- dynamic or static
11296 function Mark_Allocator (N : Node_Id) return Traverse_Result;
11297 -- Recognize an allocator node and label it as a dynamic coextension
11299 --------------------
11300 -- Mark_Allocator --
11301 --------------------
11303 function Mark_Allocator (N : Node_Id) return Traverse_Result is
11304 begin
11305 if Nkind (N) = N_Allocator then
11306 if Is_Dynamic then
11307 Set_Is_Dynamic_Coextension (N);
11309 -- If the allocator expression is potentially dynamic, it may
11310 -- be expanded out of order and require dynamic allocation
11311 -- anyway, so we treat the coextension itself as dynamic.
11312 -- Potential optimization ???
11314 elsif Nkind (Expression (N)) = N_Qualified_Expression
11315 and then Nkind (Expression (Expression (N))) = N_Op_Concat
11316 then
11317 Set_Is_Dynamic_Coextension (N);
11318 else
11319 Set_Is_Static_Coextension (N);
11320 end if;
11321 end if;
11323 return OK;
11324 end Mark_Allocator;
11326 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
11328 -- Start of processing Mark_Coextensions
11330 begin
11331 case Nkind (Context_Nod) is
11333 -- Comment here ???
11335 when N_Assignment_Statement =>
11336 Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
11338 -- An allocator that is a component of a returned aggregate
11339 -- must be dynamic.
11341 when N_Simple_Return_Statement =>
11342 declare
11343 Expr : constant Node_Id := Expression (Context_Nod);
11344 begin
11345 Is_Dynamic :=
11346 Nkind (Expr) = N_Allocator
11347 or else
11348 (Nkind (Expr) = N_Qualified_Expression
11349 and then Nkind (Expression (Expr)) = N_Aggregate);
11350 end;
11352 -- An alloctor within an object declaration in an extended return
11353 -- statement is of necessity dynamic.
11355 when N_Object_Declaration =>
11356 Is_Dynamic := Nkind (Root_Nod) = N_Allocator
11357 or else
11358 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
11360 -- This routine should not be called for constructs which may not
11361 -- contain coextensions.
11363 when others =>
11364 raise Program_Error;
11365 end case;
11367 Mark_Allocators (Root_Nod);
11368 end Mark_Coextensions;
11370 -----------------
11371 -- Must_Inline --
11372 -----------------
11374 function Must_Inline (Subp : Entity_Id) return Boolean is
11375 begin
11376 return
11377 (Optimization_Level = 0
11379 -- AAMP and VM targets have no support for inlining in the backend.
11380 -- Hence we do as much inlining as possible in the front end.
11382 or else AAMP_On_Target
11383 or else VM_Target /= No_VM)
11384 and then Has_Pragma_Inline (Subp)
11385 and then (Has_Pragma_Inline_Always (Subp) or else Front_End_Inlining);
11386 end Must_Inline;
11388 ----------------------
11389 -- Needs_One_Actual --
11390 ----------------------
11392 function Needs_One_Actual (E : Entity_Id) return Boolean is
11393 Formal : Entity_Id;
11395 begin
11396 -- Ada 2005 or later, and formals present
11398 if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then
11399 Formal := Next_Formal (First_Formal (E));
11400 while Present (Formal) loop
11401 if No (Default_Value (Formal)) then
11402 return False;
11403 end if;
11405 Next_Formal (Formal);
11406 end loop;
11408 return True;
11410 -- Ada 83/95 or no formals
11412 else
11413 return False;
11414 end if;
11415 end Needs_One_Actual;
11417 ------------------------
11418 -- New_Copy_List_Tree --
11419 ------------------------
11421 function New_Copy_List_Tree (List : List_Id) return List_Id is
11422 NL : List_Id;
11423 E : Node_Id;
11425 begin
11426 if List = No_List then
11427 return No_List;
11429 else
11430 NL := New_List;
11431 E := First (List);
11433 while Present (E) loop
11434 Append (New_Copy_Tree (E), NL);
11435 E := Next (E);
11436 end loop;
11438 return NL;
11439 end if;
11440 end New_Copy_List_Tree;
11442 -------------------
11443 -- New_Copy_Tree --
11444 -------------------
11446 use Atree.Unchecked_Access;
11447 use Atree_Private_Part;
11449 -- Our approach here requires a two pass traversal of the tree. The
11450 -- first pass visits all nodes that eventually will be copied looking
11451 -- for defining Itypes. If any defining Itypes are found, then they are
11452 -- copied, and an entry is added to the replacement map. In the second
11453 -- phase, the tree is copied, using the replacement map to replace any
11454 -- Itype references within the copied tree.
11456 -- The following hash tables are used if the Map supplied has more
11457 -- than hash threshold entries to speed up access to the map. If
11458 -- there are fewer entries, then the map is searched sequentially
11459 -- (because setting up a hash table for only a few entries takes
11460 -- more time than it saves.
11462 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
11463 -- Hash function used for hash operations
11465 -------------------
11466 -- New_Copy_Hash --
11467 -------------------
11469 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
11470 begin
11471 return Nat (E) mod (NCT_Header_Num'Last + 1);
11472 end New_Copy_Hash;
11474 ---------------
11475 -- NCT_Assoc --
11476 ---------------
11478 -- The hash table NCT_Assoc associates old entities in the table
11479 -- with their corresponding new entities (i.e. the pairs of entries
11480 -- presented in the original Map argument are Key-Element pairs).
11482 package NCT_Assoc is new Simple_HTable (
11483 Header_Num => NCT_Header_Num,
11484 Element => Entity_Id,
11485 No_Element => Empty,
11486 Key => Entity_Id,
11487 Hash => New_Copy_Hash,
11488 Equal => Types."=");
11490 ---------------------
11491 -- NCT_Itype_Assoc --
11492 ---------------------
11494 -- The hash table NCT_Itype_Assoc contains entries only for those
11495 -- old nodes which have a non-empty Associated_Node_For_Itype set.
11496 -- The key is the associated node, and the element is the new node
11497 -- itself (NOT the associated node for the new node).
11499 package NCT_Itype_Assoc is new Simple_HTable (
11500 Header_Num => NCT_Header_Num,
11501 Element => Entity_Id,
11502 No_Element => Empty,
11503 Key => Entity_Id,
11504 Hash => New_Copy_Hash,
11505 Equal => Types."=");
11507 -- Start of processing for New_Copy_Tree function
11509 function New_Copy_Tree
11510 (Source : Node_Id;
11511 Map : Elist_Id := No_Elist;
11512 New_Sloc : Source_Ptr := No_Location;
11513 New_Scope : Entity_Id := Empty) return Node_Id
11515 Actual_Map : Elist_Id := Map;
11516 -- This is the actual map for the copy. It is initialized with the
11517 -- given elements, and then enlarged as required for Itypes that are
11518 -- copied during the first phase of the copy operation. The visit
11519 -- procedures add elements to this map as Itypes are encountered.
11520 -- The reason we cannot use Map directly, is that it may well be
11521 -- (and normally is) initialized to No_Elist, and if we have mapped
11522 -- entities, we have to reset it to point to a real Elist.
11524 function Assoc (N : Node_Or_Entity_Id) return Node_Id;
11525 -- Called during second phase to map entities into their corresponding
11526 -- copies using Actual_Map. If the argument is not an entity, or is not
11527 -- in Actual_Map, then it is returned unchanged.
11529 procedure Build_NCT_Hash_Tables;
11530 -- Builds hash tables (number of elements >= threshold value)
11532 function Copy_Elist_With_Replacement
11533 (Old_Elist : Elist_Id) return Elist_Id;
11534 -- Called during second phase to copy element list doing replacements
11536 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
11537 -- Called during the second phase to process a copied Itype. The actual
11538 -- copy happened during the first phase (so that we could make the entry
11539 -- in the mapping), but we still have to deal with the descendents of
11540 -- the copied Itype and copy them where necessary.
11542 function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
11543 -- Called during second phase to copy list doing replacements
11545 function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
11546 -- Called during second phase to copy node doing replacements
11548 procedure Visit_Elist (E : Elist_Id);
11549 -- Called during first phase to visit all elements of an Elist
11551 procedure Visit_Field (F : Union_Id; N : Node_Id);
11552 -- Visit a single field, recursing to call Visit_Node or Visit_List
11553 -- if the field is a syntactic descendent of the current node (i.e.
11554 -- its parent is Node N).
11556 procedure Visit_Itype (Old_Itype : Entity_Id);
11557 -- Called during first phase to visit subsidiary fields of a defining
11558 -- Itype, and also create a copy and make an entry in the replacement
11559 -- map for the new copy.
11561 procedure Visit_List (L : List_Id);
11562 -- Called during first phase to visit all elements of a List
11564 procedure Visit_Node (N : Node_Or_Entity_Id);
11565 -- Called during first phase to visit a node and all its subtrees
11567 -----------
11568 -- Assoc --
11569 -----------
11571 function Assoc (N : Node_Or_Entity_Id) return Node_Id is
11572 E : Elmt_Id;
11573 Ent : Entity_Id;
11575 begin
11576 if not Has_Extension (N) or else No (Actual_Map) then
11577 return N;
11579 elsif NCT_Hash_Tables_Used then
11580 Ent := NCT_Assoc.Get (Entity_Id (N));
11582 if Present (Ent) then
11583 return Ent;
11584 else
11585 return N;
11586 end if;
11588 -- No hash table used, do serial search
11590 else
11591 E := First_Elmt (Actual_Map);
11592 while Present (E) loop
11593 if Node (E) = N then
11594 return Node (Next_Elmt (E));
11595 else
11596 E := Next_Elmt (Next_Elmt (E));
11597 end if;
11598 end loop;
11599 end if;
11601 return N;
11602 end Assoc;
11604 ---------------------------
11605 -- Build_NCT_Hash_Tables --
11606 ---------------------------
11608 procedure Build_NCT_Hash_Tables is
11609 Elmt : Elmt_Id;
11610 Ent : Entity_Id;
11611 begin
11612 if NCT_Hash_Table_Setup then
11613 NCT_Assoc.Reset;
11614 NCT_Itype_Assoc.Reset;
11615 end if;
11617 Elmt := First_Elmt (Actual_Map);
11618 while Present (Elmt) loop
11619 Ent := Node (Elmt);
11621 -- Get new entity, and associate old and new
11623 Next_Elmt (Elmt);
11624 NCT_Assoc.Set (Ent, Node (Elmt));
11626 if Is_Type (Ent) then
11627 declare
11628 Anode : constant Entity_Id :=
11629 Associated_Node_For_Itype (Ent);
11631 begin
11632 if Present (Anode) then
11634 -- Enter a link between the associated node of the
11635 -- old Itype and the new Itype, for updating later
11636 -- when node is copied.
11638 NCT_Itype_Assoc.Set (Anode, Node (Elmt));
11639 end if;
11640 end;
11641 end if;
11643 Next_Elmt (Elmt);
11644 end loop;
11646 NCT_Hash_Tables_Used := True;
11647 NCT_Hash_Table_Setup := True;
11648 end Build_NCT_Hash_Tables;
11650 ---------------------------------
11651 -- Copy_Elist_With_Replacement --
11652 ---------------------------------
11654 function Copy_Elist_With_Replacement
11655 (Old_Elist : Elist_Id) return Elist_Id
11657 M : Elmt_Id;
11658 New_Elist : Elist_Id;
11660 begin
11661 if No (Old_Elist) then
11662 return No_Elist;
11664 else
11665 New_Elist := New_Elmt_List;
11667 M := First_Elmt (Old_Elist);
11668 while Present (M) loop
11669 Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
11670 Next_Elmt (M);
11671 end loop;
11672 end if;
11674 return New_Elist;
11675 end Copy_Elist_With_Replacement;
11677 ---------------------------------
11678 -- Copy_Itype_With_Replacement --
11679 ---------------------------------
11681 -- This routine exactly parallels its phase one analog Visit_Itype,
11683 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
11684 begin
11685 -- Translate Next_Entity, Scope and Etype fields, in case they
11686 -- reference entities that have been mapped into copies.
11688 Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
11689 Set_Etype (New_Itype, Assoc (Etype (New_Itype)));
11691 if Present (New_Scope) then
11692 Set_Scope (New_Itype, New_Scope);
11693 else
11694 Set_Scope (New_Itype, Assoc (Scope (New_Itype)));
11695 end if;
11697 -- Copy referenced fields
11699 if Is_Discrete_Type (New_Itype) then
11700 Set_Scalar_Range (New_Itype,
11701 Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
11703 elsif Has_Discriminants (Base_Type (New_Itype)) then
11704 Set_Discriminant_Constraint (New_Itype,
11705 Copy_Elist_With_Replacement
11706 (Discriminant_Constraint (New_Itype)));
11708 elsif Is_Array_Type (New_Itype) then
11709 if Present (First_Index (New_Itype)) then
11710 Set_First_Index (New_Itype,
11711 First (Copy_List_With_Replacement
11712 (List_Containing (First_Index (New_Itype)))));
11713 end if;
11715 if Is_Packed (New_Itype) then
11716 Set_Packed_Array_Type (New_Itype,
11717 Copy_Node_With_Replacement
11718 (Packed_Array_Type (New_Itype)));
11719 end if;
11720 end if;
11721 end Copy_Itype_With_Replacement;
11723 --------------------------------
11724 -- Copy_List_With_Replacement --
11725 --------------------------------
11727 function Copy_List_With_Replacement
11728 (Old_List : List_Id) return List_Id
11730 New_List : List_Id;
11731 E : Node_Id;
11733 begin
11734 if Old_List = No_List then
11735 return No_List;
11737 else
11738 New_List := Empty_List;
11740 E := First (Old_List);
11741 while Present (E) loop
11742 Append (Copy_Node_With_Replacement (E), New_List);
11743 Next (E);
11744 end loop;
11746 return New_List;
11747 end if;
11748 end Copy_List_With_Replacement;
11750 --------------------------------
11751 -- Copy_Node_With_Replacement --
11752 --------------------------------
11754 function Copy_Node_With_Replacement
11755 (Old_Node : Node_Id) return Node_Id
11757 New_Node : Node_Id;
11759 procedure Adjust_Named_Associations
11760 (Old_Node : Node_Id;
11761 New_Node : Node_Id);
11762 -- If a call node has named associations, these are chained through
11763 -- the First_Named_Actual, Next_Named_Actual links. These must be
11764 -- propagated separately to the new parameter list, because these
11765 -- are not syntactic fields.
11767 function Copy_Field_With_Replacement
11768 (Field : Union_Id) return Union_Id;
11769 -- Given Field, which is a field of Old_Node, return a copy of it
11770 -- if it is a syntactic field (i.e. its parent is Node), setting
11771 -- the parent of the copy to poit to New_Node. Otherwise returns
11772 -- the field (possibly mapped if it is an entity).
11774 -------------------------------
11775 -- Adjust_Named_Associations --
11776 -------------------------------
11778 procedure Adjust_Named_Associations
11779 (Old_Node : Node_Id;
11780 New_Node : Node_Id)
11782 Old_E : Node_Id;
11783 New_E : Node_Id;
11785 Old_Next : Node_Id;
11786 New_Next : Node_Id;
11788 begin
11789 Old_E := First (Parameter_Associations (Old_Node));
11790 New_E := First (Parameter_Associations (New_Node));
11791 while Present (Old_E) loop
11792 if Nkind (Old_E) = N_Parameter_Association
11793 and then Present (Next_Named_Actual (Old_E))
11794 then
11795 if First_Named_Actual (Old_Node)
11796 = Explicit_Actual_Parameter (Old_E)
11797 then
11798 Set_First_Named_Actual
11799 (New_Node, Explicit_Actual_Parameter (New_E));
11800 end if;
11802 -- Now scan parameter list from the beginning,to locate
11803 -- next named actual, which can be out of order.
11805 Old_Next := First (Parameter_Associations (Old_Node));
11806 New_Next := First (Parameter_Associations (New_Node));
11808 while Nkind (Old_Next) /= N_Parameter_Association
11809 or else Explicit_Actual_Parameter (Old_Next)
11810 /= Next_Named_Actual (Old_E)
11811 loop
11812 Next (Old_Next);
11813 Next (New_Next);
11814 end loop;
11816 Set_Next_Named_Actual
11817 (New_E, Explicit_Actual_Parameter (New_Next));
11818 end if;
11820 Next (Old_E);
11821 Next (New_E);
11822 end loop;
11823 end Adjust_Named_Associations;
11825 ---------------------------------
11826 -- Copy_Field_With_Replacement --
11827 ---------------------------------
11829 function Copy_Field_With_Replacement
11830 (Field : Union_Id) return Union_Id
11832 begin
11833 if Field = Union_Id (Empty) then
11834 return Field;
11836 elsif Field in Node_Range then
11837 declare
11838 Old_N : constant Node_Id := Node_Id (Field);
11839 New_N : Node_Id;
11841 begin
11842 -- If syntactic field, as indicated by the parent pointer
11843 -- being set, then copy the referenced node recursively.
11845 if Parent (Old_N) = Old_Node then
11846 New_N := Copy_Node_With_Replacement (Old_N);
11848 if New_N /= Old_N then
11849 Set_Parent (New_N, New_Node);
11850 end if;
11852 -- For semantic fields, update possible entity reference
11853 -- from the replacement map.
11855 else
11856 New_N := Assoc (Old_N);
11857 end if;
11859 return Union_Id (New_N);
11860 end;
11862 elsif Field in List_Range then
11863 declare
11864 Old_L : constant List_Id := List_Id (Field);
11865 New_L : List_Id;
11867 begin
11868 -- If syntactic field, as indicated by the parent pointer,
11869 -- then recursively copy the entire referenced list.
11871 if Parent (Old_L) = Old_Node then
11872 New_L := Copy_List_With_Replacement (Old_L);
11873 Set_Parent (New_L, New_Node);
11875 -- For semantic list, just returned unchanged
11877 else
11878 New_L := Old_L;
11879 end if;
11881 return Union_Id (New_L);
11882 end;
11884 -- Anything other than a list or a node is returned unchanged
11886 else
11887 return Field;
11888 end if;
11889 end Copy_Field_With_Replacement;
11891 -- Start of processing for Copy_Node_With_Replacement
11893 begin
11894 if Old_Node <= Empty_Or_Error then
11895 return Old_Node;
11897 elsif Has_Extension (Old_Node) then
11898 return Assoc (Old_Node);
11900 else
11901 New_Node := New_Copy (Old_Node);
11903 -- If the node we are copying is the associated node of a
11904 -- previously copied Itype, then adjust the associated node
11905 -- of the copy of that Itype accordingly.
11907 if Present (Actual_Map) then
11908 declare
11909 E : Elmt_Id;
11910 Ent : Entity_Id;
11912 begin
11913 -- Case of hash table used
11915 if NCT_Hash_Tables_Used then
11916 Ent := NCT_Itype_Assoc.Get (Old_Node);
11918 if Present (Ent) then
11919 Set_Associated_Node_For_Itype (Ent, New_Node);
11920 end if;
11922 -- Case of no hash table used
11924 else
11925 E := First_Elmt (Actual_Map);
11926 while Present (E) loop
11927 if Is_Itype (Node (E))
11928 and then
11929 Old_Node = Associated_Node_For_Itype (Node (E))
11930 then
11931 Set_Associated_Node_For_Itype
11932 (Node (Next_Elmt (E)), New_Node);
11933 end if;
11935 E := Next_Elmt (Next_Elmt (E));
11936 end loop;
11937 end if;
11938 end;
11939 end if;
11941 -- Recursively copy descendents
11943 Set_Field1
11944 (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
11945 Set_Field2
11946 (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
11947 Set_Field3
11948 (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
11949 Set_Field4
11950 (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
11951 Set_Field5
11952 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
11954 -- Adjust Sloc of new node if necessary
11956 if New_Sloc /= No_Location then
11957 Set_Sloc (New_Node, New_Sloc);
11959 -- If we adjust the Sloc, then we are essentially making
11960 -- a completely new node, so the Comes_From_Source flag
11961 -- should be reset to the proper default value.
11963 Nodes.Table (New_Node).Comes_From_Source :=
11964 Default_Node.Comes_From_Source;
11965 end if;
11967 -- If the node is call and has named associations,
11968 -- set the corresponding links in the copy.
11970 if (Nkind (Old_Node) = N_Function_Call
11971 or else Nkind (Old_Node) = N_Entry_Call_Statement
11972 or else
11973 Nkind (Old_Node) = N_Procedure_Call_Statement)
11974 and then Present (First_Named_Actual (Old_Node))
11975 then
11976 Adjust_Named_Associations (Old_Node, New_Node);
11977 end if;
11979 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
11980 -- The replacement mechanism applies to entities, and is not used
11981 -- here. Eventually we may need a more general graph-copying
11982 -- routine. For now, do a sequential search to find desired node.
11984 if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
11985 and then Present (First_Real_Statement (Old_Node))
11986 then
11987 declare
11988 Old_F : constant Node_Id := First_Real_Statement (Old_Node);
11989 N1, N2 : Node_Id;
11991 begin
11992 N1 := First (Statements (Old_Node));
11993 N2 := First (Statements (New_Node));
11995 while N1 /= Old_F loop
11996 Next (N1);
11997 Next (N2);
11998 end loop;
12000 Set_First_Real_Statement (New_Node, N2);
12001 end;
12002 end if;
12003 end if;
12005 -- All done, return copied node
12007 return New_Node;
12008 end Copy_Node_With_Replacement;
12010 -----------------
12011 -- Visit_Elist --
12012 -----------------
12014 procedure Visit_Elist (E : Elist_Id) is
12015 Elmt : Elmt_Id;
12016 begin
12017 if Present (E) then
12018 Elmt := First_Elmt (E);
12020 while Elmt /= No_Elmt loop
12021 Visit_Node (Node (Elmt));
12022 Next_Elmt (Elmt);
12023 end loop;
12024 end if;
12025 end Visit_Elist;
12027 -----------------
12028 -- Visit_Field --
12029 -----------------
12031 procedure Visit_Field (F : Union_Id; N : Node_Id) is
12032 begin
12033 if F = Union_Id (Empty) then
12034 return;
12036 elsif F in Node_Range then
12038 -- Copy node if it is syntactic, i.e. its parent pointer is
12039 -- set to point to the field that referenced it (certain
12040 -- Itypes will also meet this criterion, which is fine, since
12041 -- these are clearly Itypes that do need to be copied, since
12042 -- we are copying their parent.)
12044 if Parent (Node_Id (F)) = N then
12045 Visit_Node (Node_Id (F));
12046 return;
12048 -- Another case, if we are pointing to an Itype, then we want
12049 -- to copy it if its associated node is somewhere in the tree
12050 -- being copied.
12052 -- Note: the exclusion of self-referential copies is just an
12053 -- optimization, since the search of the already copied list
12054 -- would catch it, but it is a common case (Etype pointing
12055 -- to itself for an Itype that is a base type).
12057 elsif Has_Extension (Node_Id (F))
12058 and then Is_Itype (Entity_Id (F))
12059 and then Node_Id (F) /= N
12060 then
12061 declare
12062 P : Node_Id;
12064 begin
12065 P := Associated_Node_For_Itype (Node_Id (F));
12066 while Present (P) loop
12067 if P = Source then
12068 Visit_Node (Node_Id (F));
12069 return;
12070 else
12071 P := Parent (P);
12072 end if;
12073 end loop;
12075 -- An Itype whose parent is not being copied definitely
12076 -- should NOT be copied, since it does not belong in any
12077 -- sense to the copied subtree.
12079 return;
12080 end;
12081 end if;
12083 elsif F in List_Range
12084 and then Parent (List_Id (F)) = N
12085 then
12086 Visit_List (List_Id (F));
12087 return;
12088 end if;
12089 end Visit_Field;
12091 -----------------
12092 -- Visit_Itype --
12093 -----------------
12095 procedure Visit_Itype (Old_Itype : Entity_Id) is
12096 New_Itype : Entity_Id;
12097 E : Elmt_Id;
12098 Ent : Entity_Id;
12100 begin
12101 -- Itypes that describe the designated type of access to subprograms
12102 -- have the structure of subprogram declarations, with signatures,
12103 -- etc. Either we duplicate the signatures completely, or choose to
12104 -- share such itypes, which is fine because their elaboration will
12105 -- have no side effects.
12107 if Ekind (Old_Itype) = E_Subprogram_Type then
12108 return;
12109 end if;
12111 New_Itype := New_Copy (Old_Itype);
12113 -- The new Itype has all the attributes of the old one, and
12114 -- we just copy the contents of the entity. However, the back-end
12115 -- needs different names for debugging purposes, so we create a
12116 -- new internal name for it in all cases.
12118 Set_Chars (New_Itype, New_Internal_Name ('T'));
12120 -- If our associated node is an entity that has already been copied,
12121 -- then set the associated node of the copy to point to the right
12122 -- copy. If we have copied an Itype that is itself the associated
12123 -- node of some previously copied Itype, then we set the right
12124 -- pointer in the other direction.
12126 if Present (Actual_Map) then
12128 -- Case of hash tables used
12130 if NCT_Hash_Tables_Used then
12132 Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
12134 if Present (Ent) then
12135 Set_Associated_Node_For_Itype (New_Itype, Ent);
12136 end if;
12138 Ent := NCT_Itype_Assoc.Get (Old_Itype);
12139 if Present (Ent) then
12140 Set_Associated_Node_For_Itype (Ent, New_Itype);
12142 -- If the hash table has no association for this Itype and
12143 -- its associated node, enter one now.
12145 else
12146 NCT_Itype_Assoc.Set
12147 (Associated_Node_For_Itype (Old_Itype), New_Itype);
12148 end if;
12150 -- Case of hash tables not used
12152 else
12153 E := First_Elmt (Actual_Map);
12154 while Present (E) loop
12155 if Associated_Node_For_Itype (Old_Itype) = Node (E) then
12156 Set_Associated_Node_For_Itype
12157 (New_Itype, Node (Next_Elmt (E)));
12158 end if;
12160 if Is_Type (Node (E))
12161 and then
12162 Old_Itype = Associated_Node_For_Itype (Node (E))
12163 then
12164 Set_Associated_Node_For_Itype
12165 (Node (Next_Elmt (E)), New_Itype);
12166 end if;
12168 E := Next_Elmt (Next_Elmt (E));
12169 end loop;
12170 end if;
12171 end if;
12173 if Present (Freeze_Node (New_Itype)) then
12174 Set_Is_Frozen (New_Itype, False);
12175 Set_Freeze_Node (New_Itype, Empty);
12176 end if;
12178 -- Add new association to map
12180 if No (Actual_Map) then
12181 Actual_Map := New_Elmt_List;
12182 end if;
12184 Append_Elmt (Old_Itype, Actual_Map);
12185 Append_Elmt (New_Itype, Actual_Map);
12187 if NCT_Hash_Tables_Used then
12188 NCT_Assoc.Set (Old_Itype, New_Itype);
12190 else
12191 NCT_Table_Entries := NCT_Table_Entries + 1;
12193 if NCT_Table_Entries > NCT_Hash_Threshold then
12194 Build_NCT_Hash_Tables;
12195 end if;
12196 end if;
12198 -- If a record subtype is simply copied, the entity list will be
12199 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
12201 if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
12202 Set_Cloned_Subtype (New_Itype, Old_Itype);
12203 end if;
12205 -- Visit descendents that eventually get copied
12207 Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
12209 if Is_Discrete_Type (Old_Itype) then
12210 Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
12212 elsif Has_Discriminants (Base_Type (Old_Itype)) then
12213 -- ??? This should involve call to Visit_Field
12214 Visit_Elist (Discriminant_Constraint (Old_Itype));
12216 elsif Is_Array_Type (Old_Itype) then
12217 if Present (First_Index (Old_Itype)) then
12218 Visit_Field (Union_Id (List_Containing
12219 (First_Index (Old_Itype))),
12220 Old_Itype);
12221 end if;
12223 if Is_Packed (Old_Itype) then
12224 Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
12225 Old_Itype);
12226 end if;
12227 end if;
12228 end Visit_Itype;
12230 ----------------
12231 -- Visit_List --
12232 ----------------
12234 procedure Visit_List (L : List_Id) is
12235 N : Node_Id;
12236 begin
12237 if L /= No_List then
12238 N := First (L);
12240 while Present (N) loop
12241 Visit_Node (N);
12242 Next (N);
12243 end loop;
12244 end if;
12245 end Visit_List;
12247 ----------------
12248 -- Visit_Node --
12249 ----------------
12251 procedure Visit_Node (N : Node_Or_Entity_Id) is
12253 -- Start of processing for Visit_Node
12255 begin
12256 -- Handle case of an Itype, which must be copied
12258 if Has_Extension (N)
12259 and then Is_Itype (N)
12260 then
12261 -- Nothing to do if already in the list. This can happen with an
12262 -- Itype entity that appears more than once in the tree.
12263 -- Note that we do not want to visit descendents in this case.
12265 -- Test for already in list when hash table is used
12267 if NCT_Hash_Tables_Used then
12268 if Present (NCT_Assoc.Get (Entity_Id (N))) then
12269 return;
12270 end if;
12272 -- Test for already in list when hash table not used
12274 else
12275 declare
12276 E : Elmt_Id;
12277 begin
12278 if Present (Actual_Map) then
12279 E := First_Elmt (Actual_Map);
12280 while Present (E) loop
12281 if Node (E) = N then
12282 return;
12283 else
12284 E := Next_Elmt (Next_Elmt (E));
12285 end if;
12286 end loop;
12287 end if;
12288 end;
12289 end if;
12291 Visit_Itype (N);
12292 end if;
12294 -- Visit descendents
12296 Visit_Field (Field1 (N), N);
12297 Visit_Field (Field2 (N), N);
12298 Visit_Field (Field3 (N), N);
12299 Visit_Field (Field4 (N), N);
12300 Visit_Field (Field5 (N), N);
12301 end Visit_Node;
12303 -- Start of processing for New_Copy_Tree
12305 begin
12306 Actual_Map := Map;
12308 -- See if we should use hash table
12310 if No (Actual_Map) then
12311 NCT_Hash_Tables_Used := False;
12313 else
12314 declare
12315 Elmt : Elmt_Id;
12317 begin
12318 NCT_Table_Entries := 0;
12320 Elmt := First_Elmt (Actual_Map);
12321 while Present (Elmt) loop
12322 NCT_Table_Entries := NCT_Table_Entries + 1;
12323 Next_Elmt (Elmt);
12324 Next_Elmt (Elmt);
12325 end loop;
12327 if NCT_Table_Entries > NCT_Hash_Threshold then
12328 Build_NCT_Hash_Tables;
12329 else
12330 NCT_Hash_Tables_Used := False;
12331 end if;
12332 end;
12333 end if;
12335 -- Hash table set up if required, now start phase one by visiting
12336 -- top node (we will recursively visit the descendents).
12338 Visit_Node (Source);
12340 -- Now the second phase of the copy can start. First we process
12341 -- all the mapped entities, copying their descendents.
12343 if Present (Actual_Map) then
12344 declare
12345 Elmt : Elmt_Id;
12346 New_Itype : Entity_Id;
12347 begin
12348 Elmt := First_Elmt (Actual_Map);
12349 while Present (Elmt) loop
12350 Next_Elmt (Elmt);
12351 New_Itype := Node (Elmt);
12352 Copy_Itype_With_Replacement (New_Itype);
12353 Next_Elmt (Elmt);
12354 end loop;
12355 end;
12356 end if;
12358 -- Now we can copy the actual tree
12360 return Copy_Node_With_Replacement (Source);
12361 end New_Copy_Tree;
12363 -------------------------
12364 -- New_External_Entity --
12365 -------------------------
12367 function New_External_Entity
12368 (Kind : Entity_Kind;
12369 Scope_Id : Entity_Id;
12370 Sloc_Value : Source_Ptr;
12371 Related_Id : Entity_Id;
12372 Suffix : Character;
12373 Suffix_Index : Nat := 0;
12374 Prefix : Character := ' ') return Entity_Id
12376 N : constant Entity_Id :=
12377 Make_Defining_Identifier (Sloc_Value,
12378 New_External_Name
12379 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
12381 begin
12382 Set_Ekind (N, Kind);
12383 Set_Is_Internal (N, True);
12384 Append_Entity (N, Scope_Id);
12385 Set_Public_Status (N);
12387 if Kind in Type_Kind then
12388 Init_Size_Align (N);
12389 end if;
12391 return N;
12392 end New_External_Entity;
12394 -------------------------
12395 -- New_Internal_Entity --
12396 -------------------------
12398 function New_Internal_Entity
12399 (Kind : Entity_Kind;
12400 Scope_Id : Entity_Id;
12401 Sloc_Value : Source_Ptr;
12402 Id_Char : Character) return Entity_Id
12404 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
12406 begin
12407 Set_Ekind (N, Kind);
12408 Set_Is_Internal (N, True);
12409 Append_Entity (N, Scope_Id);
12411 if Kind in Type_Kind then
12412 Init_Size_Align (N);
12413 end if;
12415 return N;
12416 end New_Internal_Entity;
12418 -----------------
12419 -- Next_Actual --
12420 -----------------
12422 function Next_Actual (Actual_Id : Node_Id) return Node_Id is
12423 N : Node_Id;
12425 begin
12426 -- If we are pointing at a positional parameter, it is a member of a
12427 -- node list (the list of parameters), and the next parameter is the
12428 -- next node on the list, unless we hit a parameter association, then
12429 -- we shift to using the chain whose head is the First_Named_Actual in
12430 -- the parent, and then is threaded using the Next_Named_Actual of the
12431 -- Parameter_Association. All this fiddling is because the original node
12432 -- list is in the textual call order, and what we need is the
12433 -- declaration order.
12435 if Is_List_Member (Actual_Id) then
12436 N := Next (Actual_Id);
12438 if Nkind (N) = N_Parameter_Association then
12439 return First_Named_Actual (Parent (Actual_Id));
12440 else
12441 return N;
12442 end if;
12444 else
12445 return Next_Named_Actual (Parent (Actual_Id));
12446 end if;
12447 end Next_Actual;
12449 procedure Next_Actual (Actual_Id : in out Node_Id) is
12450 begin
12451 Actual_Id := Next_Actual (Actual_Id);
12452 end Next_Actual;
12454 ---------------------
12455 -- No_Scalar_Parts --
12456 ---------------------
12458 function No_Scalar_Parts (T : Entity_Id) return Boolean is
12459 C : Entity_Id;
12461 begin
12462 if Is_Scalar_Type (T) then
12463 return False;
12465 elsif Is_Array_Type (T) then
12466 return No_Scalar_Parts (Component_Type (T));
12468 elsif Is_Record_Type (T) or else Has_Discriminants (T) then
12469 C := First_Component_Or_Discriminant (T);
12470 while Present (C) loop
12471 if not No_Scalar_Parts (Etype (C)) then
12472 return False;
12473 else
12474 Next_Component_Or_Discriminant (C);
12475 end if;
12476 end loop;
12477 end if;
12479 return True;
12480 end No_Scalar_Parts;
12482 -----------------------
12483 -- Normalize_Actuals --
12484 -----------------------
12486 -- Chain actuals according to formals of subprogram. If there are no named
12487 -- associations, the chain is simply the list of Parameter Associations,
12488 -- since the order is the same as the declaration order. If there are named
12489 -- associations, then the First_Named_Actual field in the N_Function_Call
12490 -- or N_Procedure_Call_Statement node points to the Parameter_Association
12491 -- node for the parameter that comes first in declaration order. The
12492 -- remaining named parameters are then chained in declaration order using
12493 -- Next_Named_Actual.
12495 -- This routine also verifies that the number of actuals is compatible with
12496 -- the number and default values of formals, but performs no type checking
12497 -- (type checking is done by the caller).
12499 -- If the matching succeeds, Success is set to True and the caller proceeds
12500 -- with type-checking. If the match is unsuccessful, then Success is set to
12501 -- False, and the caller attempts a different interpretation, if there is
12502 -- one.
12504 -- If the flag Report is on, the call is not overloaded, and a failure to
12505 -- match can be reported here, rather than in the caller.
12507 procedure Normalize_Actuals
12508 (N : Node_Id;
12509 S : Entity_Id;
12510 Report : Boolean;
12511 Success : out Boolean)
12513 Actuals : constant List_Id := Parameter_Associations (N);
12514 Actual : Node_Id := Empty;
12515 Formal : Entity_Id;
12516 Last : Node_Id := Empty;
12517 First_Named : Node_Id := Empty;
12518 Found : Boolean;
12520 Formals_To_Match : Integer := 0;
12521 Actuals_To_Match : Integer := 0;
12523 procedure Chain (A : Node_Id);
12524 -- Add named actual at the proper place in the list, using the
12525 -- Next_Named_Actual link.
12527 function Reporting return Boolean;
12528 -- Determines if an error is to be reported. To report an error, we
12529 -- need Report to be True, and also we do not report errors caused
12530 -- by calls to init procs that occur within other init procs. Such
12531 -- errors must always be cascaded errors, since if all the types are
12532 -- declared correctly, the compiler will certainly build decent calls!
12534 -----------
12535 -- Chain --
12536 -----------
12538 procedure Chain (A : Node_Id) is
12539 begin
12540 if No (Last) then
12542 -- Call node points to first actual in list
12544 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
12546 else
12547 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
12548 end if;
12550 Last := A;
12551 Set_Next_Named_Actual (Last, Empty);
12552 end Chain;
12554 ---------------
12555 -- Reporting --
12556 ---------------
12558 function Reporting return Boolean is
12559 begin
12560 if not Report then
12561 return False;
12563 elsif not Within_Init_Proc then
12564 return True;
12566 elsif Is_Init_Proc (Entity (Name (N))) then
12567 return False;
12569 else
12570 return True;
12571 end if;
12572 end Reporting;
12574 -- Start of processing for Normalize_Actuals
12576 begin
12577 if Is_Access_Type (S) then
12579 -- The name in the call is a function call that returns an access
12580 -- to subprogram. The designated type has the list of formals.
12582 Formal := First_Formal (Designated_Type (S));
12583 else
12584 Formal := First_Formal (S);
12585 end if;
12587 while Present (Formal) loop
12588 Formals_To_Match := Formals_To_Match + 1;
12589 Next_Formal (Formal);
12590 end loop;
12592 -- Find if there is a named association, and verify that no positional
12593 -- associations appear after named ones.
12595 if Present (Actuals) then
12596 Actual := First (Actuals);
12597 end if;
12599 while Present (Actual)
12600 and then Nkind (Actual) /= N_Parameter_Association
12601 loop
12602 Actuals_To_Match := Actuals_To_Match + 1;
12603 Next (Actual);
12604 end loop;
12606 if No (Actual) and Actuals_To_Match = Formals_To_Match then
12608 -- Most common case: positional notation, no defaults
12610 Success := True;
12611 return;
12613 elsif Actuals_To_Match > Formals_To_Match then
12615 -- Too many actuals: will not work
12617 if Reporting then
12618 if Is_Entity_Name (Name (N)) then
12619 Error_Msg_N ("too many arguments in call to&", Name (N));
12620 else
12621 Error_Msg_N ("too many arguments in call", N);
12622 end if;
12623 end if;
12625 Success := False;
12626 return;
12627 end if;
12629 First_Named := Actual;
12631 while Present (Actual) loop
12632 if Nkind (Actual) /= N_Parameter_Association then
12633 Error_Msg_N
12634 ("positional parameters not allowed after named ones", Actual);
12635 Success := False;
12636 return;
12638 else
12639 Actuals_To_Match := Actuals_To_Match + 1;
12640 end if;
12642 Next (Actual);
12643 end loop;
12645 if Present (Actuals) then
12646 Actual := First (Actuals);
12647 end if;
12649 Formal := First_Formal (S);
12650 while Present (Formal) loop
12652 -- Match the formals in order. If the corresponding actual is
12653 -- positional, nothing to do. Else scan the list of named actuals
12654 -- to find the one with the right name.
12656 if Present (Actual)
12657 and then Nkind (Actual) /= N_Parameter_Association
12658 then
12659 Next (Actual);
12660 Actuals_To_Match := Actuals_To_Match - 1;
12661 Formals_To_Match := Formals_To_Match - 1;
12663 else
12664 -- For named parameters, search the list of actuals to find
12665 -- one that matches the next formal name.
12667 Actual := First_Named;
12668 Found := False;
12669 while Present (Actual) loop
12670 if Chars (Selector_Name (Actual)) = Chars (Formal) then
12671 Found := True;
12672 Chain (Actual);
12673 Actuals_To_Match := Actuals_To_Match - 1;
12674 Formals_To_Match := Formals_To_Match - 1;
12675 exit;
12676 end if;
12678 Next (Actual);
12679 end loop;
12681 if not Found then
12682 if Ekind (Formal) /= E_In_Parameter
12683 or else No (Default_Value (Formal))
12684 then
12685 if Reporting then
12686 if (Comes_From_Source (S)
12687 or else Sloc (S) = Standard_Location)
12688 and then Is_Overloadable (S)
12689 then
12690 if No (Actuals)
12691 and then
12692 (Nkind (Parent (N)) = N_Procedure_Call_Statement
12693 or else
12694 (Nkind (Parent (N)) = N_Function_Call
12695 or else
12696 Nkind (Parent (N)) = N_Parameter_Association))
12697 and then Ekind (S) /= E_Function
12698 then
12699 Set_Etype (N, Etype (S));
12700 else
12701 Error_Msg_Name_1 := Chars (S);
12702 Error_Msg_Sloc := Sloc (S);
12703 Error_Msg_NE
12704 ("missing argument for parameter & " &
12705 "in call to % declared #", N, Formal);
12706 end if;
12708 elsif Is_Overloadable (S) then
12709 Error_Msg_Name_1 := Chars (S);
12711 -- Point to type derivation that generated the
12712 -- operation.
12714 Error_Msg_Sloc := Sloc (Parent (S));
12716 Error_Msg_NE
12717 ("missing argument for parameter & " &
12718 "in call to % (inherited) #", N, Formal);
12720 else
12721 Error_Msg_NE
12722 ("missing argument for parameter &", N, Formal);
12723 end if;
12724 end if;
12726 Success := False;
12727 return;
12729 else
12730 Formals_To_Match := Formals_To_Match - 1;
12731 end if;
12732 end if;
12733 end if;
12735 Next_Formal (Formal);
12736 end loop;
12738 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
12739 Success := True;
12740 return;
12742 else
12743 if Reporting then
12745 -- Find some superfluous named actual that did not get
12746 -- attached to the list of associations.
12748 Actual := First (Actuals);
12749 while Present (Actual) loop
12750 if Nkind (Actual) = N_Parameter_Association
12751 and then Actual /= Last
12752 and then No (Next_Named_Actual (Actual))
12753 then
12754 Error_Msg_N ("unmatched actual & in call",
12755 Selector_Name (Actual));
12756 exit;
12757 end if;
12759 Next (Actual);
12760 end loop;
12761 end if;
12763 Success := False;
12764 return;
12765 end if;
12766 end Normalize_Actuals;
12768 --------------------------------
12769 -- Note_Possible_Modification --
12770 --------------------------------
12772 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
12773 Modification_Comes_From_Source : constant Boolean :=
12774 Comes_From_Source (Parent (N));
12776 Ent : Entity_Id;
12777 Exp : Node_Id;
12779 begin
12780 -- Loop to find referenced entity, if there is one
12782 Exp := N;
12783 loop
12784 <<Continue>>
12785 Ent := Empty;
12787 if Is_Entity_Name (Exp) then
12788 Ent := Entity (Exp);
12790 -- If the entity is missing, it is an undeclared identifier,
12791 -- and there is nothing to annotate.
12793 if No (Ent) then
12794 return;
12795 end if;
12797 elsif Nkind (Exp) = N_Explicit_Dereference then
12798 declare
12799 P : constant Node_Id := Prefix (Exp);
12801 begin
12802 -- In formal verification mode, keep track of all reads and
12803 -- writes through explicit dereferences.
12805 if SPARK_Mode then
12806 SPARK_Specific.Generate_Dereference (N, 'm');
12807 end if;
12809 if Nkind (P) = N_Selected_Component
12810 and then
12811 Present (Entry_Formal (Entity (Selector_Name (P))))
12812 then
12813 -- Case of a reference to an entry formal
12815 Ent := Entry_Formal (Entity (Selector_Name (P)));
12817 elsif Nkind (P) = N_Identifier
12818 and then Nkind (Parent (Entity (P))) = N_Object_Declaration
12819 and then Present (Expression (Parent (Entity (P))))
12820 and then Nkind (Expression (Parent (Entity (P))))
12821 = N_Reference
12822 then
12823 -- Case of a reference to a value on which side effects have
12824 -- been removed.
12826 Exp := Prefix (Expression (Parent (Entity (P))));
12827 goto Continue;
12829 else
12830 return;
12832 end if;
12833 end;
12835 elsif Nkind_In (Exp, N_Type_Conversion,
12836 N_Unchecked_Type_Conversion)
12837 then
12838 Exp := Expression (Exp);
12839 goto Continue;
12841 elsif Nkind_In (Exp, N_Slice,
12842 N_Indexed_Component,
12843 N_Selected_Component)
12844 then
12845 Exp := Prefix (Exp);
12846 goto Continue;
12848 else
12849 return;
12850 end if;
12852 -- Now look for entity being referenced
12854 if Present (Ent) then
12855 if Is_Object (Ent) then
12856 if Comes_From_Source (Exp)
12857 or else Modification_Comes_From_Source
12858 then
12859 -- Give warning if pragma unmodified given and we are
12860 -- sure this is a modification.
12862 if Has_Pragma_Unmodified (Ent) and then Sure then
12863 Error_Msg_NE
12864 ("??pragma Unmodified given for &!", N, Ent);
12865 end if;
12867 Set_Never_Set_In_Source (Ent, False);
12868 end if;
12870 Set_Is_True_Constant (Ent, False);
12871 Set_Current_Value (Ent, Empty);
12872 Set_Is_Known_Null (Ent, False);
12874 if not Can_Never_Be_Null (Ent) then
12875 Set_Is_Known_Non_Null (Ent, False);
12876 end if;
12878 -- Follow renaming chain
12880 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
12881 and then Present (Renamed_Object (Ent))
12882 then
12883 Exp := Renamed_Object (Ent);
12884 goto Continue;
12886 -- The expression may be the renaming of a subcomponent of an
12887 -- array or container. The assignment to the subcomponent is
12888 -- a modification of the container.
12890 elsif Comes_From_Source (Original_Node (Exp))
12891 and then Nkind_In (Original_Node (Exp), N_Selected_Component,
12892 N_Indexed_Component)
12893 then
12894 Exp := Prefix (Original_Node (Exp));
12895 goto Continue;
12896 end if;
12898 -- Generate a reference only if the assignment comes from
12899 -- source. This excludes, for example, calls to a dispatching
12900 -- assignment operation when the left-hand side is tagged.
12902 -- Why is SPARK mode different here ???
12904 if Modification_Comes_From_Source or SPARK_Mode then
12905 Generate_Reference (Ent, Exp, 'm');
12907 -- If the target of the assignment is the bound variable
12908 -- in an iterator, indicate that the corresponding array
12909 -- or container is also modified.
12911 if Ada_Version >= Ada_2012
12912 and then
12913 Nkind (Parent (Ent)) = N_Iterator_Specification
12914 then
12915 declare
12916 Domain : constant Node_Id := Name (Parent (Ent));
12918 begin
12919 -- TBD : in the full version of the construct, the
12920 -- domain of iteration can be given by an expression.
12922 if Is_Entity_Name (Domain) then
12923 Generate_Reference (Entity (Domain), Exp, 'm');
12924 Set_Is_True_Constant (Entity (Domain), False);
12925 Set_Never_Set_In_Source (Entity (Domain), False);
12926 end if;
12927 end;
12928 end if;
12929 end if;
12931 Check_Nested_Access (Ent);
12932 end if;
12934 Kill_Checks (Ent);
12936 -- If we are sure this is a modification from source, and we know
12937 -- this modifies a constant, then give an appropriate warning.
12939 if Overlays_Constant (Ent)
12940 and then Modification_Comes_From_Source
12941 and then Sure
12942 then
12943 declare
12944 A : constant Node_Id := Address_Clause (Ent);
12945 begin
12946 if Present (A) then
12947 declare
12948 Exp : constant Node_Id := Expression (A);
12949 begin
12950 if Nkind (Exp) = N_Attribute_Reference
12951 and then Attribute_Name (Exp) = Name_Address
12952 and then Is_Entity_Name (Prefix (Exp))
12953 then
12954 Error_Msg_Sloc := Sloc (A);
12955 Error_Msg_NE
12956 ("constant& may be modified via address "
12957 & "clause#??", N, Entity (Prefix (Exp)));
12958 end if;
12959 end;
12960 end if;
12961 end;
12962 end if;
12964 return;
12965 end if;
12966 end loop;
12967 end Note_Possible_Modification;
12969 -------------------------
12970 -- Object_Access_Level --
12971 -------------------------
12973 -- Returns the static accessibility level of the view denoted by Obj. Note
12974 -- that the value returned is the result of a call to Scope_Depth. Only
12975 -- scope depths associated with dynamic scopes can actually be returned.
12976 -- Since only relative levels matter for accessibility checking, the fact
12977 -- that the distance between successive levels of accessibility is not
12978 -- always one is immaterial (invariant: if level(E2) is deeper than
12979 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
12981 function Object_Access_Level (Obj : Node_Id) return Uint is
12982 function Is_Interface_Conversion (N : Node_Id) return Boolean;
12983 -- Determine whether N is a construct of the form
12984 -- Some_Type (Operand._tag'Address)
12985 -- This construct appears in the context of dispatching calls.
12987 function Reference_To (Obj : Node_Id) return Node_Id;
12988 -- An explicit dereference is created when removing side-effects from
12989 -- expressions for constraint checking purposes. In this case a local
12990 -- access type is created for it. The correct access level is that of
12991 -- the original source node. We detect this case by noting that the
12992 -- prefix of the dereference is created by an object declaration whose
12993 -- initial expression is a reference.
12995 -----------------------------
12996 -- Is_Interface_Conversion --
12997 -----------------------------
12999 function Is_Interface_Conversion (N : Node_Id) return Boolean is
13000 begin
13001 return
13002 Nkind (N) = N_Unchecked_Type_Conversion
13003 and then Nkind (Expression (N)) = N_Attribute_Reference
13004 and then Attribute_Name (Expression (N)) = Name_Address;
13005 end Is_Interface_Conversion;
13007 ------------------
13008 -- Reference_To --
13009 ------------------
13011 function Reference_To (Obj : Node_Id) return Node_Id is
13012 Pref : constant Node_Id := Prefix (Obj);
13013 begin
13014 if Is_Entity_Name (Pref)
13015 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
13016 and then Present (Expression (Parent (Entity (Pref))))
13017 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
13018 then
13019 return (Prefix (Expression (Parent (Entity (Pref)))));
13020 else
13021 return Empty;
13022 end if;
13023 end Reference_To;
13025 -- Local variables
13027 E : Entity_Id;
13029 -- Start of processing for Object_Access_Level
13031 begin
13032 if Nkind (Obj) = N_Defining_Identifier
13033 or else Is_Entity_Name (Obj)
13034 then
13035 if Nkind (Obj) = N_Defining_Identifier then
13036 E := Obj;
13037 else
13038 E := Entity (Obj);
13039 end if;
13041 if Is_Prival (E) then
13042 E := Prival_Link (E);
13043 end if;
13045 -- If E is a type then it denotes a current instance. For this case
13046 -- we add one to the normal accessibility level of the type to ensure
13047 -- that current instances are treated as always being deeper than
13048 -- than the level of any visible named access type (see 3.10.2(21)).
13050 if Is_Type (E) then
13051 return Type_Access_Level (E) + 1;
13053 elsif Present (Renamed_Object (E)) then
13054 return Object_Access_Level (Renamed_Object (E));
13056 -- Similarly, if E is a component of the current instance of a
13057 -- protected type, any instance of it is assumed to be at a deeper
13058 -- level than the type. For a protected object (whose type is an
13059 -- anonymous protected type) its components are at the same level
13060 -- as the type itself.
13062 elsif not Is_Overloadable (E)
13063 and then Ekind (Scope (E)) = E_Protected_Type
13064 and then Comes_From_Source (Scope (E))
13065 then
13066 return Type_Access_Level (Scope (E)) + 1;
13068 else
13069 return Scope_Depth (Enclosing_Dynamic_Scope (E));
13070 end if;
13072 elsif Nkind (Obj) = N_Selected_Component then
13073 if Is_Access_Type (Etype (Prefix (Obj))) then
13074 return Type_Access_Level (Etype (Prefix (Obj)));
13075 else
13076 return Object_Access_Level (Prefix (Obj));
13077 end if;
13079 elsif Nkind (Obj) = N_Indexed_Component then
13080 if Is_Access_Type (Etype (Prefix (Obj))) then
13081 return Type_Access_Level (Etype (Prefix (Obj)));
13082 else
13083 return Object_Access_Level (Prefix (Obj));
13084 end if;
13086 elsif Nkind (Obj) = N_Explicit_Dereference then
13088 -- If the prefix is a selected access discriminant then we make a
13089 -- recursive call on the prefix, which will in turn check the level
13090 -- of the prefix object of the selected discriminant.
13092 if Nkind (Prefix (Obj)) = N_Selected_Component
13093 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
13094 and then
13095 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
13096 then
13097 return Object_Access_Level (Prefix (Obj));
13099 -- Detect an interface conversion in the context of a dispatching
13100 -- call. Use the original form of the conversion to find the access
13101 -- level of the operand.
13103 elsif Is_Interface (Etype (Obj))
13104 and then Is_Interface_Conversion (Prefix (Obj))
13105 and then Nkind (Original_Node (Obj)) = N_Type_Conversion
13106 then
13107 return Object_Access_Level (Original_Node (Obj));
13109 elsif not Comes_From_Source (Obj) then
13110 declare
13111 Ref : constant Node_Id := Reference_To (Obj);
13112 begin
13113 if Present (Ref) then
13114 return Object_Access_Level (Ref);
13115 else
13116 return Type_Access_Level (Etype (Prefix (Obj)));
13117 end if;
13118 end;
13120 else
13121 return Type_Access_Level (Etype (Prefix (Obj)));
13122 end if;
13124 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
13125 return Object_Access_Level (Expression (Obj));
13127 elsif Nkind (Obj) = N_Function_Call then
13129 -- Function results are objects, so we get either the access level of
13130 -- the function or, in the case of an indirect call, the level of the
13131 -- access-to-subprogram type. (This code is used for Ada 95, but it
13132 -- looks wrong, because it seems that we should be checking the level
13133 -- of the call itself, even for Ada 95. However, using the Ada 2005
13134 -- version of the code causes regressions in several tests that are
13135 -- compiled with -gnat95. ???)
13137 if Ada_Version < Ada_2005 then
13138 if Is_Entity_Name (Name (Obj)) then
13139 return Subprogram_Access_Level (Entity (Name (Obj)));
13140 else
13141 return Type_Access_Level (Etype (Prefix (Name (Obj))));
13142 end if;
13144 -- For Ada 2005, the level of the result object of a function call is
13145 -- defined to be the level of the call's innermost enclosing master.
13146 -- We determine that by querying the depth of the innermost enclosing
13147 -- dynamic scope.
13149 else
13150 Return_Master_Scope_Depth_Of_Call : declare
13152 function Innermost_Master_Scope_Depth
13153 (N : Node_Id) return Uint;
13154 -- Returns the scope depth of the given node's innermost
13155 -- enclosing dynamic scope (effectively the accessibility
13156 -- level of the innermost enclosing master).
13158 ----------------------------------
13159 -- Innermost_Master_Scope_Depth --
13160 ----------------------------------
13162 function Innermost_Master_Scope_Depth
13163 (N : Node_Id) return Uint
13165 Node_Par : Node_Id := Parent (N);
13167 begin
13168 -- Locate the nearest enclosing node (by traversing Parents)
13169 -- that Defining_Entity can be applied to, and return the
13170 -- depth of that entity's nearest enclosing dynamic scope.
13172 while Present (Node_Par) loop
13173 case Nkind (Node_Par) is
13174 when N_Component_Declaration |
13175 N_Entry_Declaration |
13176 N_Formal_Object_Declaration |
13177 N_Formal_Type_Declaration |
13178 N_Full_Type_Declaration |
13179 N_Incomplete_Type_Declaration |
13180 N_Loop_Parameter_Specification |
13181 N_Object_Declaration |
13182 N_Protected_Type_Declaration |
13183 N_Private_Extension_Declaration |
13184 N_Private_Type_Declaration |
13185 N_Subtype_Declaration |
13186 N_Function_Specification |
13187 N_Procedure_Specification |
13188 N_Task_Type_Declaration |
13189 N_Body_Stub |
13190 N_Generic_Instantiation |
13191 N_Proper_Body |
13192 N_Implicit_Label_Declaration |
13193 N_Package_Declaration |
13194 N_Single_Task_Declaration |
13195 N_Subprogram_Declaration |
13196 N_Generic_Declaration |
13197 N_Renaming_Declaration |
13198 N_Block_Statement |
13199 N_Formal_Subprogram_Declaration |
13200 N_Abstract_Subprogram_Declaration |
13201 N_Entry_Body |
13202 N_Exception_Declaration |
13203 N_Formal_Package_Declaration |
13204 N_Number_Declaration |
13205 N_Package_Specification |
13206 N_Parameter_Specification |
13207 N_Single_Protected_Declaration |
13208 N_Subunit =>
13210 return Scope_Depth
13211 (Nearest_Dynamic_Scope
13212 (Defining_Entity (Node_Par)));
13214 when others =>
13215 null;
13216 end case;
13218 Node_Par := Parent (Node_Par);
13219 end loop;
13221 pragma Assert (False);
13223 -- Should never reach the following return
13225 return Scope_Depth (Current_Scope) + 1;
13226 end Innermost_Master_Scope_Depth;
13228 -- Start of processing for Return_Master_Scope_Depth_Of_Call
13230 begin
13231 return Innermost_Master_Scope_Depth (Obj);
13232 end Return_Master_Scope_Depth_Of_Call;
13233 end if;
13235 -- For convenience we handle qualified expressions, even though they
13236 -- aren't technically object names.
13238 elsif Nkind (Obj) = N_Qualified_Expression then
13239 return Object_Access_Level (Expression (Obj));
13241 -- Otherwise return the scope level of Standard. (If there are cases
13242 -- that fall through to this point they will be treated as having
13243 -- global accessibility for now. ???)
13245 else
13246 return Scope_Depth (Standard_Standard);
13247 end if;
13248 end Object_Access_Level;
13250 --------------------------
13251 -- Original_Aspect_Name --
13252 --------------------------
13254 function Original_Aspect_Name (N : Node_Id) return Name_Id is
13255 Pras : Node_Id;
13256 Name : Name_Id;
13258 begin
13259 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma));
13260 Pras := N;
13262 if Is_Rewrite_Substitution (Pras)
13263 and then Nkind (Original_Node (Pras)) = N_Pragma
13264 then
13265 Pras := Original_Node (Pras);
13266 end if;
13268 -- Case where we came from aspect specication
13270 if Nkind (Pras) = N_Pragma and then From_Aspect_Specification (Pras) then
13271 Pras := Corresponding_Aspect (Pras);
13272 end if;
13274 -- Get name from aspect or pragma
13276 if Nkind (Pras) = N_Pragma then
13277 Name := Pragma_Name (Pras);
13278 else
13279 Name := Chars (Identifier (Pras));
13280 end if;
13282 -- Deal with 'Class
13284 if Class_Present (Pras) then
13285 case Name is
13287 -- Names that need converting to special _xxx form
13289 when Name_Pre |
13290 Name_Pre_Class =>
13291 Name := Name_uPre;
13293 when Name_Post |
13294 Name_Post_Class =>
13295 Name := Name_uPost;
13297 when Name_Invariant =>
13298 Name := Name_uInvariant;
13300 when Name_Type_Invariant |
13301 Name_Type_Invariant_Class =>
13302 Name := Name_uType_Invariant;
13304 -- Nothing to do for other cases (e.g. a Check that derived
13305 -- from Pre_Class and has the flag set). Also we do nothing
13306 -- if the name is already in special _xxx form.
13308 when others =>
13309 null;
13310 end case;
13311 end if;
13313 return Name;
13314 end Original_Aspect_Name;
13315 --------------------------------------
13316 -- Original_Corresponding_Operation --
13317 --------------------------------------
13319 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
13321 Typ : constant Entity_Id := Find_Dispatching_Type (S);
13323 begin
13324 -- If S is an inherited primitive S2 the original corresponding
13325 -- operation of S is the original corresponding operation of S2
13327 if Present (Alias (S))
13328 and then Find_Dispatching_Type (Alias (S)) /= Typ
13329 then
13330 return Original_Corresponding_Operation (Alias (S));
13332 -- If S overrides an inherited subprogram S2 the original corresponding
13333 -- operation of S is the original corresponding operation of S2
13335 elsif Present (Overridden_Operation (S)) then
13336 return Original_Corresponding_Operation (Overridden_Operation (S));
13338 -- otherwise it is S itself
13340 else
13341 return S;
13342 end if;
13343 end Original_Corresponding_Operation;
13345 -----------------------
13346 -- Private_Component --
13347 -----------------------
13349 function Private_Component (Type_Id : Entity_Id) return Entity_Id is
13350 Ancestor : constant Entity_Id := Base_Type (Type_Id);
13352 function Trace_Components
13353 (T : Entity_Id;
13354 Check : Boolean) return Entity_Id;
13355 -- Recursive function that does the work, and checks against circular
13356 -- definition for each subcomponent type.
13358 ----------------------
13359 -- Trace_Components --
13360 ----------------------
13362 function Trace_Components
13363 (T : Entity_Id;
13364 Check : Boolean) return Entity_Id
13366 Btype : constant Entity_Id := Base_Type (T);
13367 Component : Entity_Id;
13368 P : Entity_Id;
13369 Candidate : Entity_Id := Empty;
13371 begin
13372 if Check and then Btype = Ancestor then
13373 Error_Msg_N ("circular type definition", Type_Id);
13374 return Any_Type;
13375 end if;
13377 if Is_Private_Type (Btype)
13378 and then not Is_Generic_Type (Btype)
13379 then
13380 if Present (Full_View (Btype))
13381 and then Is_Record_Type (Full_View (Btype))
13382 and then not Is_Frozen (Btype)
13383 then
13384 -- To indicate that the ancestor depends on a private type, the
13385 -- current Btype is sufficient. However, to check for circular
13386 -- definition we must recurse on the full view.
13388 Candidate := Trace_Components (Full_View (Btype), True);
13390 if Candidate = Any_Type then
13391 return Any_Type;
13392 else
13393 return Btype;
13394 end if;
13396 else
13397 return Btype;
13398 end if;
13400 elsif Is_Array_Type (Btype) then
13401 return Trace_Components (Component_Type (Btype), True);
13403 elsif Is_Record_Type (Btype) then
13404 Component := First_Entity (Btype);
13405 while Present (Component)
13406 and then Comes_From_Source (Component)
13407 loop
13408 -- Skip anonymous types generated by constrained components
13410 if not Is_Type (Component) then
13411 P := Trace_Components (Etype (Component), True);
13413 if Present (P) then
13414 if P = Any_Type then
13415 return P;
13416 else
13417 Candidate := P;
13418 end if;
13419 end if;
13420 end if;
13422 Next_Entity (Component);
13423 end loop;
13425 return Candidate;
13427 else
13428 return Empty;
13429 end if;
13430 end Trace_Components;
13432 -- Start of processing for Private_Component
13434 begin
13435 return Trace_Components (Type_Id, False);
13436 end Private_Component;
13438 ---------------------------
13439 -- Primitive_Names_Match --
13440 ---------------------------
13442 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
13444 function Non_Internal_Name (E : Entity_Id) return Name_Id;
13445 -- Given an internal name, returns the corresponding non-internal name
13447 ------------------------
13448 -- Non_Internal_Name --
13449 ------------------------
13451 function Non_Internal_Name (E : Entity_Id) return Name_Id is
13452 begin
13453 Get_Name_String (Chars (E));
13454 Name_Len := Name_Len - 1;
13455 return Name_Find;
13456 end Non_Internal_Name;
13458 -- Start of processing for Primitive_Names_Match
13460 begin
13461 pragma Assert (Present (E1) and then Present (E2));
13463 return Chars (E1) = Chars (E2)
13464 or else
13465 (not Is_Internal_Name (Chars (E1))
13466 and then Is_Internal_Name (Chars (E2))
13467 and then Non_Internal_Name (E2) = Chars (E1))
13468 or else
13469 (not Is_Internal_Name (Chars (E2))
13470 and then Is_Internal_Name (Chars (E1))
13471 and then Non_Internal_Name (E1) = Chars (E2))
13472 or else
13473 (Is_Predefined_Dispatching_Operation (E1)
13474 and then Is_Predefined_Dispatching_Operation (E2)
13475 and then Same_TSS (E1, E2))
13476 or else
13477 (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
13478 end Primitive_Names_Match;
13480 -----------------------
13481 -- Process_End_Label --
13482 -----------------------
13484 procedure Process_End_Label
13485 (N : Node_Id;
13486 Typ : Character;
13487 Ent : Entity_Id)
13489 Loc : Source_Ptr;
13490 Nam : Node_Id;
13491 Scop : Entity_Id;
13493 Label_Ref : Boolean;
13494 -- Set True if reference to end label itself is required
13496 Endl : Node_Id;
13497 -- Gets set to the operator symbol or identifier that references the
13498 -- entity Ent. For the child unit case, this is the identifier from the
13499 -- designator. For other cases, this is simply Endl.
13501 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
13502 -- N is an identifier node that appears as a parent unit reference in
13503 -- the case where Ent is a child unit. This procedure generates an
13504 -- appropriate cross-reference entry. E is the corresponding entity.
13506 -------------------------
13507 -- Generate_Parent_Ref --
13508 -------------------------
13510 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
13511 begin
13512 -- If names do not match, something weird, skip reference
13514 if Chars (E) = Chars (N) then
13516 -- Generate the reference. We do NOT consider this as a reference
13517 -- for unreferenced symbol purposes.
13519 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
13521 if Style_Check then
13522 Style.Check_Identifier (N, E);
13523 end if;
13524 end if;
13525 end Generate_Parent_Ref;
13527 -- Start of processing for Process_End_Label
13529 begin
13530 -- If no node, ignore. This happens in some error situations, and
13531 -- also for some internally generated structures where no end label
13532 -- references are required in any case.
13534 if No (N) then
13535 return;
13536 end if;
13538 -- Nothing to do if no End_Label, happens for internally generated
13539 -- constructs where we don't want an end label reference anyway. Also
13540 -- nothing to do if Endl is a string literal, which means there was
13541 -- some prior error (bad operator symbol)
13543 Endl := End_Label (N);
13545 if No (Endl) or else Nkind (Endl) = N_String_Literal then
13546 return;
13547 end if;
13549 -- Reference node is not in extended main source unit
13551 if not In_Extended_Main_Source_Unit (N) then
13553 -- Generally we do not collect references except for the extended
13554 -- main source unit. The one exception is the 'e' entry for a
13555 -- package spec, where it is useful for a client to have the
13556 -- ending information to define scopes.
13558 if Typ /= 'e' then
13559 return;
13561 else
13562 Label_Ref := False;
13564 -- For this case, we can ignore any parent references, but we
13565 -- need the package name itself for the 'e' entry.
13567 if Nkind (Endl) = N_Designator then
13568 Endl := Identifier (Endl);
13569 end if;
13570 end if;
13572 -- Reference is in extended main source unit
13574 else
13575 Label_Ref := True;
13577 -- For designator, generate references for the parent entries
13579 if Nkind (Endl) = N_Designator then
13581 -- Generate references for the prefix if the END line comes from
13582 -- source (otherwise we do not need these references) We climb the
13583 -- scope stack to find the expected entities.
13585 if Comes_From_Source (Endl) then
13586 Nam := Name (Endl);
13587 Scop := Current_Scope;
13588 while Nkind (Nam) = N_Selected_Component loop
13589 Scop := Scope (Scop);
13590 exit when No (Scop);
13591 Generate_Parent_Ref (Selector_Name (Nam), Scop);
13592 Nam := Prefix (Nam);
13593 end loop;
13595 if Present (Scop) then
13596 Generate_Parent_Ref (Nam, Scope (Scop));
13597 end if;
13598 end if;
13600 Endl := Identifier (Endl);
13601 end if;
13602 end if;
13604 -- If the end label is not for the given entity, then either we have
13605 -- some previous error, or this is a generic instantiation for which
13606 -- we do not need to make a cross-reference in this case anyway. In
13607 -- either case we simply ignore the call.
13609 if Chars (Ent) /= Chars (Endl) then
13610 return;
13611 end if;
13613 -- If label was really there, then generate a normal reference and then
13614 -- adjust the location in the end label to point past the name (which
13615 -- should almost always be the semicolon).
13617 Loc := Sloc (Endl);
13619 if Comes_From_Source (Endl) then
13621 -- If a label reference is required, then do the style check and
13622 -- generate an l-type cross-reference entry for the label
13624 if Label_Ref then
13625 if Style_Check then
13626 Style.Check_Identifier (Endl, Ent);
13627 end if;
13629 Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
13630 end if;
13632 -- Set the location to point past the label (normally this will
13633 -- mean the semicolon immediately following the label). This is
13634 -- done for the sake of the 'e' or 't' entry generated below.
13636 Get_Decoded_Name_String (Chars (Endl));
13637 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
13639 else
13640 -- In SPARK mode, no missing label is allowed for packages and
13641 -- subprogram bodies. Detect those cases by testing whether
13642 -- Process_End_Label was called for a body (Typ = 't') or a package.
13644 if Restriction_Check_Required (SPARK_05)
13645 and then (Typ = 't' or else Ekind (Ent) = E_Package)
13646 then
13647 Error_Msg_Node_1 := Endl;
13648 Check_SPARK_Restriction ("`END &` required", Endl, Force => True);
13649 end if;
13650 end if;
13652 -- Now generate the e/t reference
13654 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
13656 -- Restore Sloc, in case modified above, since we have an identifier
13657 -- and the normal Sloc should be left set in the tree.
13659 Set_Sloc (Endl, Loc);
13660 end Process_End_Label;
13662 ----------------
13663 -- Referenced --
13664 ----------------
13666 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is
13667 Seen : Boolean := False;
13669 function Is_Reference (N : Node_Id) return Traverse_Result;
13670 -- Determine whether node N denotes a reference to Id. If this is the
13671 -- case, set global flag Seen to True and stop the traversal.
13673 ------------------
13674 -- Is_Reference --
13675 ------------------
13677 function Is_Reference (N : Node_Id) return Traverse_Result is
13678 begin
13679 if Is_Entity_Name (N)
13680 and then Present (Entity (N))
13681 and then Entity (N) = Id
13682 then
13683 Seen := True;
13684 return Abandon;
13685 else
13686 return OK;
13687 end if;
13688 end Is_Reference;
13690 procedure Inspect_Expression is new Traverse_Proc (Is_Reference);
13692 -- Start of processing for Referenced
13694 begin
13695 Inspect_Expression (Expr);
13696 return Seen;
13697 end Referenced;
13699 ------------------------------------
13700 -- References_Generic_Formal_Type --
13701 ------------------------------------
13703 function References_Generic_Formal_Type (N : Node_Id) return Boolean is
13705 function Process (N : Node_Id) return Traverse_Result;
13706 -- Process one node in search for generic formal type
13708 -------------
13709 -- Process --
13710 -------------
13712 function Process (N : Node_Id) return Traverse_Result is
13713 begin
13714 if Nkind (N) in N_Has_Entity then
13715 declare
13716 E : constant Entity_Id := Entity (N);
13717 begin
13718 if Present (E) then
13719 if Is_Generic_Type (E) then
13720 return Abandon;
13721 elsif Present (Etype (E))
13722 and then Is_Generic_Type (Etype (E))
13723 then
13724 return Abandon;
13725 end if;
13726 end if;
13727 end;
13728 end if;
13730 return Atree.OK;
13731 end Process;
13733 function Traverse is new Traverse_Func (Process);
13734 -- Traverse tree to look for generic type
13736 begin
13737 if Inside_A_Generic then
13738 return Traverse (N) = Abandon;
13739 else
13740 return False;
13741 end if;
13742 end References_Generic_Formal_Type;
13744 --------------------
13745 -- Remove_Homonym --
13746 --------------------
13748 procedure Remove_Homonym (E : Entity_Id) is
13749 Prev : Entity_Id := Empty;
13750 H : Entity_Id;
13752 begin
13753 if E = Current_Entity (E) then
13754 if Present (Homonym (E)) then
13755 Set_Current_Entity (Homonym (E));
13756 else
13757 Set_Name_Entity_Id (Chars (E), Empty);
13758 end if;
13760 else
13761 H := Current_Entity (E);
13762 while Present (H) and then H /= E loop
13763 Prev := H;
13764 H := Homonym (H);
13765 end loop;
13767 -- If E is not on the homonym chain, nothing to do
13769 if Present (H) then
13770 Set_Homonym (Prev, Homonym (E));
13771 end if;
13772 end if;
13773 end Remove_Homonym;
13775 ---------------------
13776 -- Rep_To_Pos_Flag --
13777 ---------------------
13779 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
13780 begin
13781 return New_Occurrence_Of
13782 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
13783 end Rep_To_Pos_Flag;
13785 --------------------
13786 -- Require_Entity --
13787 --------------------
13789 procedure Require_Entity (N : Node_Id) is
13790 begin
13791 if Is_Entity_Name (N) and then No (Entity (N)) then
13792 if Total_Errors_Detected /= 0 then
13793 Set_Entity (N, Any_Id);
13794 else
13795 raise Program_Error;
13796 end if;
13797 end if;
13798 end Require_Entity;
13800 ------------------------------
13801 -- Requires_Transient_Scope --
13802 ------------------------------
13804 -- A transient scope is required when variable-sized temporaries are
13805 -- allocated in the primary or secondary stack, or when finalization
13806 -- actions must be generated before the next instruction.
13808 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
13809 Typ : constant Entity_Id := Underlying_Type (Id);
13811 -- Start of processing for Requires_Transient_Scope
13813 begin
13814 -- This is a private type which is not completed yet. This can only
13815 -- happen in a default expression (of a formal parameter or of a
13816 -- record component). Do not expand transient scope in this case
13818 if No (Typ) then
13819 return False;
13821 -- Do not expand transient scope for non-existent procedure return
13823 elsif Typ = Standard_Void_Type then
13824 return False;
13826 -- Elementary types do not require a transient scope
13828 elsif Is_Elementary_Type (Typ) then
13829 return False;
13831 -- Generally, indefinite subtypes require a transient scope, since the
13832 -- back end cannot generate temporaries, since this is not a valid type
13833 -- for declaring an object. It might be possible to relax this in the
13834 -- future, e.g. by declaring the maximum possible space for the type.
13836 elsif Is_Indefinite_Subtype (Typ) then
13837 return True;
13839 -- Functions returning tagged types may dispatch on result so their
13840 -- returned value is allocated on the secondary stack. Controlled
13841 -- type temporaries need finalization.
13843 elsif Is_Tagged_Type (Typ)
13844 or else Has_Controlled_Component (Typ)
13845 then
13846 return not Is_Value_Type (Typ);
13848 -- Record type
13850 elsif Is_Record_Type (Typ) then
13851 declare
13852 Comp : Entity_Id;
13853 begin
13854 Comp := First_Entity (Typ);
13855 while Present (Comp) loop
13856 if Ekind (Comp) = E_Component
13857 and then Requires_Transient_Scope (Etype (Comp))
13858 then
13859 return True;
13860 else
13861 Next_Entity (Comp);
13862 end if;
13863 end loop;
13864 end;
13866 return False;
13868 -- String literal types never require transient scope
13870 elsif Ekind (Typ) = E_String_Literal_Subtype then
13871 return False;
13873 -- Array type. Note that we already know that this is a constrained
13874 -- array, since unconstrained arrays will fail the indefinite test.
13876 elsif Is_Array_Type (Typ) then
13878 -- If component type requires a transient scope, the array does too
13880 if Requires_Transient_Scope (Component_Type (Typ)) then
13881 return True;
13883 -- Otherwise, we only need a transient scope if the size depends on
13884 -- the value of one or more discriminants.
13886 else
13887 return Size_Depends_On_Discriminant (Typ);
13888 end if;
13890 -- All other cases do not require a transient scope
13892 else
13893 return False;
13894 end if;
13895 end Requires_Transient_Scope;
13897 --------------------------
13898 -- Reset_Analyzed_Flags --
13899 --------------------------
13901 procedure Reset_Analyzed_Flags (N : Node_Id) is
13903 function Clear_Analyzed (N : Node_Id) return Traverse_Result;
13904 -- Function used to reset Analyzed flags in tree. Note that we do
13905 -- not reset Analyzed flags in entities, since there is no need to
13906 -- reanalyze entities, and indeed, it is wrong to do so, since it
13907 -- can result in generating auxiliary stuff more than once.
13909 --------------------
13910 -- Clear_Analyzed --
13911 --------------------
13913 function Clear_Analyzed (N : Node_Id) return Traverse_Result is
13914 begin
13915 if not Has_Extension (N) then
13916 Set_Analyzed (N, False);
13917 end if;
13919 return OK;
13920 end Clear_Analyzed;
13922 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
13924 -- Start of processing for Reset_Analyzed_Flags
13926 begin
13927 Reset_Analyzed (N);
13928 end Reset_Analyzed_Flags;
13930 --------------------------------
13931 -- Returns_Unconstrained_Type --
13932 --------------------------------
13934 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
13935 begin
13936 return Ekind (Subp) = E_Function
13937 and then not Is_Scalar_Type (Etype (Subp))
13938 and then not Is_Access_Type (Etype (Subp))
13939 and then not Is_Constrained (Etype (Subp));
13940 end Returns_Unconstrained_Type;
13942 ---------------------------
13943 -- Safe_To_Capture_Value --
13944 ---------------------------
13946 function Safe_To_Capture_Value
13947 (N : Node_Id;
13948 Ent : Entity_Id;
13949 Cond : Boolean := False) return Boolean
13951 begin
13952 -- The only entities for which we track constant values are variables
13953 -- which are not renamings, constants, out parameters, and in out
13954 -- parameters, so check if we have this case.
13956 -- Note: it may seem odd to track constant values for constants, but in
13957 -- fact this routine is used for other purposes than simply capturing
13958 -- the value. In particular, the setting of Known[_Non]_Null.
13960 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
13961 or else
13962 Ekind (Ent) = E_Constant
13963 or else
13964 Ekind (Ent) = E_Out_Parameter
13965 or else
13966 Ekind (Ent) = E_In_Out_Parameter
13967 then
13968 null;
13970 -- For conditionals, we also allow loop parameters and all formals,
13971 -- including in parameters.
13973 elsif Cond
13974 and then
13975 (Ekind (Ent) = E_Loop_Parameter
13976 or else
13977 Ekind (Ent) = E_In_Parameter)
13978 then
13979 null;
13981 -- For all other cases, not just unsafe, but impossible to capture
13982 -- Current_Value, since the above are the only entities which have
13983 -- Current_Value fields.
13985 else
13986 return False;
13987 end if;
13989 -- Skip if volatile or aliased, since funny things might be going on in
13990 -- these cases which we cannot necessarily track. Also skip any variable
13991 -- for which an address clause is given, or whose address is taken. Also
13992 -- never capture value of library level variables (an attempt to do so
13993 -- can occur in the case of package elaboration code).
13995 if Treat_As_Volatile (Ent)
13996 or else Is_Aliased (Ent)
13997 or else Present (Address_Clause (Ent))
13998 or else Address_Taken (Ent)
13999 or else (Is_Library_Level_Entity (Ent)
14000 and then Ekind (Ent) = E_Variable)
14001 then
14002 return False;
14003 end if;
14005 -- OK, all above conditions are met. We also require that the scope of
14006 -- the reference be the same as the scope of the entity, not counting
14007 -- packages and blocks and loops.
14009 declare
14010 E_Scope : constant Entity_Id := Scope (Ent);
14011 R_Scope : Entity_Id;
14013 begin
14014 R_Scope := Current_Scope;
14015 while R_Scope /= Standard_Standard loop
14016 exit when R_Scope = E_Scope;
14018 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
14019 return False;
14020 else
14021 R_Scope := Scope (R_Scope);
14022 end if;
14023 end loop;
14024 end;
14026 -- We also require that the reference does not appear in a context
14027 -- where it is not sure to be executed (i.e. a conditional context
14028 -- or an exception handler). We skip this if Cond is True, since the
14029 -- capturing of values from conditional tests handles this ok.
14031 if Cond then
14032 return True;
14033 end if;
14035 declare
14036 Desc : Node_Id;
14037 P : Node_Id;
14039 begin
14040 Desc := N;
14042 -- Seems dubious that case expressions are not handled here ???
14044 P := Parent (N);
14045 while Present (P) loop
14046 if Nkind (P) = N_If_Statement
14047 or else Nkind (P) = N_Case_Statement
14048 or else (Nkind (P) in N_Short_Circuit
14049 and then Desc = Right_Opnd (P))
14050 or else (Nkind (P) = N_If_Expression
14051 and then Desc /= First (Expressions (P)))
14052 or else Nkind (P) = N_Exception_Handler
14053 or else Nkind (P) = N_Selective_Accept
14054 or else Nkind (P) = N_Conditional_Entry_Call
14055 or else Nkind (P) = N_Timed_Entry_Call
14056 or else Nkind (P) = N_Asynchronous_Select
14057 then
14058 return False;
14059 else
14060 Desc := P;
14061 P := Parent (P);
14063 -- A special Ada 2012 case: the original node may be part
14064 -- of the else_actions of a conditional expression, in which
14065 -- case it might not have been expanded yet, and appears in
14066 -- a non-syntactic list of actions. In that case it is clearly
14067 -- not safe to save a value.
14069 if No (P)
14070 and then Is_List_Member (Desc)
14071 and then No (Parent (List_Containing (Desc)))
14072 then
14073 return False;
14074 end if;
14075 end if;
14076 end loop;
14077 end;
14079 -- OK, looks safe to set value
14081 return True;
14082 end Safe_To_Capture_Value;
14084 ---------------
14085 -- Same_Name --
14086 ---------------
14088 function Same_Name (N1, N2 : Node_Id) return Boolean is
14089 K1 : constant Node_Kind := Nkind (N1);
14090 K2 : constant Node_Kind := Nkind (N2);
14092 begin
14093 if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
14094 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
14095 then
14096 return Chars (N1) = Chars (N2);
14098 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
14099 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
14100 then
14101 return Same_Name (Selector_Name (N1), Selector_Name (N2))
14102 and then Same_Name (Prefix (N1), Prefix (N2));
14104 else
14105 return False;
14106 end if;
14107 end Same_Name;
14109 -----------------
14110 -- Same_Object --
14111 -----------------
14113 function Same_Object (Node1, Node2 : Node_Id) return Boolean is
14114 N1 : constant Node_Id := Original_Node (Node1);
14115 N2 : constant Node_Id := Original_Node (Node2);
14116 -- We do the tests on original nodes, since we are most interested
14117 -- in the original source, not any expansion that got in the way.
14119 K1 : constant Node_Kind := Nkind (N1);
14120 K2 : constant Node_Kind := Nkind (N2);
14122 begin
14123 -- First case, both are entities with same entity
14125 if K1 in N_Has_Entity and then K2 in N_Has_Entity then
14126 declare
14127 EN1 : constant Entity_Id := Entity (N1);
14128 EN2 : constant Entity_Id := Entity (N2);
14129 begin
14130 if Present (EN1) and then Present (EN2)
14131 and then (Ekind_In (EN1, E_Variable, E_Constant)
14132 or else Is_Formal (EN1))
14133 and then EN1 = EN2
14134 then
14135 return True;
14136 end if;
14137 end;
14138 end if;
14140 -- Second case, selected component with same selector, same record
14142 if K1 = N_Selected_Component
14143 and then K2 = N_Selected_Component
14144 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
14145 then
14146 return Same_Object (Prefix (N1), Prefix (N2));
14148 -- Third case, indexed component with same subscripts, same array
14150 elsif K1 = N_Indexed_Component
14151 and then K2 = N_Indexed_Component
14152 and then Same_Object (Prefix (N1), Prefix (N2))
14153 then
14154 declare
14155 E1, E2 : Node_Id;
14156 begin
14157 E1 := First (Expressions (N1));
14158 E2 := First (Expressions (N2));
14159 while Present (E1) loop
14160 if not Same_Value (E1, E2) then
14161 return False;
14162 else
14163 Next (E1);
14164 Next (E2);
14165 end if;
14166 end loop;
14168 return True;
14169 end;
14171 -- Fourth case, slice of same array with same bounds
14173 elsif K1 = N_Slice
14174 and then K2 = N_Slice
14175 and then Nkind (Discrete_Range (N1)) = N_Range
14176 and then Nkind (Discrete_Range (N2)) = N_Range
14177 and then Same_Value (Low_Bound (Discrete_Range (N1)),
14178 Low_Bound (Discrete_Range (N2)))
14179 and then Same_Value (High_Bound (Discrete_Range (N1)),
14180 High_Bound (Discrete_Range (N2)))
14181 then
14182 return Same_Name (Prefix (N1), Prefix (N2));
14184 -- All other cases, not clearly the same object
14186 else
14187 return False;
14188 end if;
14189 end Same_Object;
14191 ---------------
14192 -- Same_Type --
14193 ---------------
14195 function Same_Type (T1, T2 : Entity_Id) return Boolean is
14196 begin
14197 if T1 = T2 then
14198 return True;
14200 elsif not Is_Constrained (T1)
14201 and then not Is_Constrained (T2)
14202 and then Base_Type (T1) = Base_Type (T2)
14203 then
14204 return True;
14206 -- For now don't bother with case of identical constraints, to be
14207 -- fiddled with later on perhaps (this is only used for optimization
14208 -- purposes, so it is not critical to do a best possible job)
14210 else
14211 return False;
14212 end if;
14213 end Same_Type;
14215 ----------------
14216 -- Same_Value --
14217 ----------------
14219 function Same_Value (Node1, Node2 : Node_Id) return Boolean is
14220 begin
14221 if Compile_Time_Known_Value (Node1)
14222 and then Compile_Time_Known_Value (Node2)
14223 and then Expr_Value (Node1) = Expr_Value (Node2)
14224 then
14225 return True;
14226 elsif Same_Object (Node1, Node2) then
14227 return True;
14228 else
14229 return False;
14230 end if;
14231 end Same_Value;
14233 ------------------------
14234 -- Scope_Is_Transient --
14235 ------------------------
14237 function Scope_Is_Transient return Boolean is
14238 begin
14239 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
14240 end Scope_Is_Transient;
14242 ------------------
14243 -- Scope_Within --
14244 ------------------
14246 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
14247 Scop : Entity_Id;
14249 begin
14250 Scop := Scope1;
14251 while Scop /= Standard_Standard loop
14252 Scop := Scope (Scop);
14254 if Scop = Scope2 then
14255 return True;
14256 end if;
14257 end loop;
14259 return False;
14260 end Scope_Within;
14262 --------------------------
14263 -- Scope_Within_Or_Same --
14264 --------------------------
14266 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
14267 Scop : Entity_Id;
14269 begin
14270 Scop := Scope1;
14271 while Scop /= Standard_Standard loop
14272 if Scop = Scope2 then
14273 return True;
14274 else
14275 Scop := Scope (Scop);
14276 end if;
14277 end loop;
14279 return False;
14280 end Scope_Within_Or_Same;
14282 --------------------
14283 -- Set_Convention --
14284 --------------------
14286 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
14287 begin
14288 Basic_Set_Convention (E, Val);
14290 if Is_Type (E)
14291 and then Is_Access_Subprogram_Type (Base_Type (E))
14292 and then Has_Foreign_Convention (E)
14293 then
14294 Set_Can_Use_Internal_Rep (E, False);
14295 end if;
14296 end Set_Convention;
14298 ------------------------
14299 -- Set_Current_Entity --
14300 ------------------------
14302 -- The given entity is to be set as the currently visible definition of its
14303 -- associated name (i.e. the Node_Id associated with its name). All we have
14304 -- to do is to get the name from the identifier, and then set the
14305 -- associated Node_Id to point to the given entity.
14307 procedure Set_Current_Entity (E : Entity_Id) is
14308 begin
14309 Set_Name_Entity_Id (Chars (E), E);
14310 end Set_Current_Entity;
14312 ---------------------------
14313 -- Set_Debug_Info_Needed --
14314 ---------------------------
14316 procedure Set_Debug_Info_Needed (T : Entity_Id) is
14318 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
14319 pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
14320 -- Used to set debug info in a related node if not set already
14322 --------------------------------------
14323 -- Set_Debug_Info_Needed_If_Not_Set --
14324 --------------------------------------
14326 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
14327 begin
14328 if Present (E)
14329 and then not Needs_Debug_Info (E)
14330 then
14331 Set_Debug_Info_Needed (E);
14333 -- For a private type, indicate that the full view also needs
14334 -- debug information.
14336 if Is_Type (E)
14337 and then Is_Private_Type (E)
14338 and then Present (Full_View (E))
14339 then
14340 Set_Debug_Info_Needed (Full_View (E));
14341 end if;
14342 end if;
14343 end Set_Debug_Info_Needed_If_Not_Set;
14345 -- Start of processing for Set_Debug_Info_Needed
14347 begin
14348 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which
14349 -- indicates that Debug_Info_Needed is never required for the entity.
14351 if No (T)
14352 or else Debug_Info_Off (T)
14353 then
14354 return;
14355 end if;
14357 -- Set flag in entity itself. Note that we will go through the following
14358 -- circuitry even if the flag is already set on T. That's intentional,
14359 -- it makes sure that the flag will be set in subsidiary entities.
14361 Set_Needs_Debug_Info (T);
14363 -- Set flag on subsidiary entities if not set already
14365 if Is_Object (T) then
14366 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
14368 elsif Is_Type (T) then
14369 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
14371 if Is_Record_Type (T) then
14372 declare
14373 Ent : Entity_Id := First_Entity (T);
14374 begin
14375 while Present (Ent) loop
14376 Set_Debug_Info_Needed_If_Not_Set (Ent);
14377 Next_Entity (Ent);
14378 end loop;
14379 end;
14381 -- For a class wide subtype, we also need debug information
14382 -- for the equivalent type.
14384 if Ekind (T) = E_Class_Wide_Subtype then
14385 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
14386 end if;
14388 elsif Is_Array_Type (T) then
14389 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
14391 declare
14392 Indx : Node_Id := First_Index (T);
14393 begin
14394 while Present (Indx) loop
14395 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
14396 Indx := Next_Index (Indx);
14397 end loop;
14398 end;
14400 -- For a packed array type, we also need debug information for
14401 -- the type used to represent the packed array. Conversely, we
14402 -- also need it for the former if we need it for the latter.
14404 if Is_Packed (T) then
14405 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
14406 end if;
14408 if Is_Packed_Array_Type (T) then
14409 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T));
14410 end if;
14412 elsif Is_Access_Type (T) then
14413 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
14415 elsif Is_Private_Type (T) then
14416 Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
14418 elsif Is_Protected_Type (T) then
14419 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
14420 end if;
14421 end if;
14422 end Set_Debug_Info_Needed;
14424 ---------------------------------
14425 -- Set_Entity_With_Style_Check --
14426 ---------------------------------
14428 procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
14429 Val_Actual : Entity_Id;
14430 Nod : Node_Id;
14432 begin
14433 -- Unconditionally set the entity
14435 Set_Entity (N, Val);
14437 -- Check for No_Implementation_Identifiers
14439 if Restriction_Check_Required (No_Implementation_Identifiers) then
14441 -- We have an implementation defined entity if it is marked as
14442 -- implementation defined, or is defined in a package marked as
14443 -- implementation defined. However, library packages themselves
14444 -- are excluded (we don't want to flag Interfaces itself, just
14445 -- the entities within it).
14447 if (Is_Implementation_Defined (Val)
14448 or else
14449 Is_Implementation_Defined (Scope (Val)))
14450 and then not (Ekind_In (Val, E_Package, E_Generic_Package)
14451 and then Is_Library_Level_Entity (Val))
14452 then
14453 Check_Restriction (No_Implementation_Identifiers, N);
14454 end if;
14455 end if;
14457 -- Do the style check
14459 if Style_Check
14460 and then not Suppress_Style_Checks (Val)
14461 and then not In_Instance
14462 then
14463 if Nkind (N) = N_Identifier then
14464 Nod := N;
14465 elsif Nkind (N) = N_Expanded_Name then
14466 Nod := Selector_Name (N);
14467 else
14468 return;
14469 end if;
14471 -- A special situation arises for derived operations, where we want
14472 -- to do the check against the parent (since the Sloc of the derived
14473 -- operation points to the derived type declaration itself).
14475 Val_Actual := Val;
14476 while not Comes_From_Source (Val_Actual)
14477 and then Nkind (Val_Actual) in N_Entity
14478 and then (Ekind (Val_Actual) = E_Enumeration_Literal
14479 or else Is_Subprogram (Val_Actual)
14480 or else Is_Generic_Subprogram (Val_Actual))
14481 and then Present (Alias (Val_Actual))
14482 loop
14483 Val_Actual := Alias (Val_Actual);
14484 end loop;
14486 -- Renaming declarations for generic actuals do not come from source,
14487 -- and have a different name from that of the entity they rename, so
14488 -- there is no style check to perform here.
14490 if Chars (Nod) = Chars (Val_Actual) then
14491 Style.Check_Identifier (Nod, Val_Actual);
14492 end if;
14493 end if;
14495 Set_Entity (N, Val);
14496 end Set_Entity_With_Style_Check;
14498 ------------------------
14499 -- Set_Name_Entity_Id --
14500 ------------------------
14502 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
14503 begin
14504 Set_Name_Table_Info (Id, Int (Val));
14505 end Set_Name_Entity_Id;
14507 ---------------------
14508 -- Set_Next_Actual --
14509 ---------------------
14511 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
14512 begin
14513 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
14514 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
14515 end if;
14516 end Set_Next_Actual;
14518 ----------------------------------
14519 -- Set_Optimize_Alignment_Flags --
14520 ----------------------------------
14522 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
14523 begin
14524 if Optimize_Alignment = 'S' then
14525 Set_Optimize_Alignment_Space (E);
14526 elsif Optimize_Alignment = 'T' then
14527 Set_Optimize_Alignment_Time (E);
14528 end if;
14529 end Set_Optimize_Alignment_Flags;
14531 -----------------------
14532 -- Set_Public_Status --
14533 -----------------------
14535 procedure Set_Public_Status (Id : Entity_Id) is
14536 S : constant Entity_Id := Current_Scope;
14538 function Within_HSS_Or_If (E : Entity_Id) return Boolean;
14539 -- Determines if E is defined within handled statement sequence or
14540 -- an if statement, returns True if so, False otherwise.
14542 ----------------------
14543 -- Within_HSS_Or_If --
14544 ----------------------
14546 function Within_HSS_Or_If (E : Entity_Id) return Boolean is
14547 N : Node_Id;
14548 begin
14549 N := Declaration_Node (E);
14550 loop
14551 N := Parent (N);
14553 if No (N) then
14554 return False;
14556 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
14557 N_If_Statement)
14558 then
14559 return True;
14560 end if;
14561 end loop;
14562 end Within_HSS_Or_If;
14564 -- Start of processing for Set_Public_Status
14566 begin
14567 -- Everything in the scope of Standard is public
14569 if S = Standard_Standard then
14570 Set_Is_Public (Id);
14572 -- Entity is definitely not public if enclosing scope is not public
14574 elsif not Is_Public (S) then
14575 return;
14577 -- An object or function declaration that occurs in a handled sequence
14578 -- of statements or within an if statement is the declaration for a
14579 -- temporary object or local subprogram generated by the expander. It
14580 -- never needs to be made public and furthermore, making it public can
14581 -- cause back end problems.
14583 elsif Nkind_In (Parent (Id), N_Object_Declaration,
14584 N_Function_Specification)
14585 and then Within_HSS_Or_If (Id)
14586 then
14587 return;
14589 -- Entities in public packages or records are public
14591 elsif Ekind (S) = E_Package or Is_Record_Type (S) then
14592 Set_Is_Public (Id);
14594 -- The bounds of an entry family declaration can generate object
14595 -- declarations that are visible to the back-end, e.g. in the
14596 -- the declaration of a composite type that contains tasks.
14598 elsif Is_Concurrent_Type (S)
14599 and then not Has_Completion (S)
14600 and then Nkind (Parent (Id)) = N_Object_Declaration
14601 then
14602 Set_Is_Public (Id);
14603 end if;
14604 end Set_Public_Status;
14606 -----------------------------
14607 -- Set_Referenced_Modified --
14608 -----------------------------
14610 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
14611 Pref : Node_Id;
14613 begin
14614 -- Deal with indexed or selected component where prefix is modified
14616 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
14617 Pref := Prefix (N);
14619 -- If prefix is access type, then it is the designated object that is
14620 -- being modified, which means we have no entity to set the flag on.
14622 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
14623 return;
14625 -- Otherwise chase the prefix
14627 else
14628 Set_Referenced_Modified (Pref, Out_Param);
14629 end if;
14631 -- Otherwise see if we have an entity name (only other case to process)
14633 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
14634 Set_Referenced_As_LHS (Entity (N), not Out_Param);
14635 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
14636 end if;
14637 end Set_Referenced_Modified;
14639 ----------------------------
14640 -- Set_Scope_Is_Transient --
14641 ----------------------------
14643 procedure Set_Scope_Is_Transient (V : Boolean := True) is
14644 begin
14645 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
14646 end Set_Scope_Is_Transient;
14648 -------------------
14649 -- Set_Size_Info --
14650 -------------------
14652 procedure Set_Size_Info (T1, T2 : Entity_Id) is
14653 begin
14654 -- We copy Esize, but not RM_Size, since in general RM_Size is
14655 -- subtype specific and does not get inherited by all subtypes.
14657 Set_Esize (T1, Esize (T2));
14658 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
14660 if Is_Discrete_Or_Fixed_Point_Type (T1)
14661 and then
14662 Is_Discrete_Or_Fixed_Point_Type (T2)
14663 then
14664 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
14665 end if;
14667 Set_Alignment (T1, Alignment (T2));
14668 end Set_Size_Info;
14670 --------------------
14671 -- Static_Boolean --
14672 --------------------
14674 function Static_Boolean (N : Node_Id) return Uint is
14675 begin
14676 Analyze_And_Resolve (N, Standard_Boolean);
14678 if N = Error
14679 or else Error_Posted (N)
14680 or else Etype (N) = Any_Type
14681 then
14682 return No_Uint;
14683 end if;
14685 if Is_Static_Expression (N) then
14686 if not Raises_Constraint_Error (N) then
14687 return Expr_Value (N);
14688 else
14689 return No_Uint;
14690 end if;
14692 elsif Etype (N) = Any_Type then
14693 return No_Uint;
14695 else
14696 Flag_Non_Static_Expr
14697 ("static boolean expression required here", N);
14698 return No_Uint;
14699 end if;
14700 end Static_Boolean;
14702 --------------------
14703 -- Static_Integer --
14704 --------------------
14706 function Static_Integer (N : Node_Id) return Uint is
14707 begin
14708 Analyze_And_Resolve (N, Any_Integer);
14710 if N = Error
14711 or else Error_Posted (N)
14712 or else Etype (N) = Any_Type
14713 then
14714 return No_Uint;
14715 end if;
14717 if Is_Static_Expression (N) then
14718 if not Raises_Constraint_Error (N) then
14719 return Expr_Value (N);
14720 else
14721 return No_Uint;
14722 end if;
14724 elsif Etype (N) = Any_Type then
14725 return No_Uint;
14727 else
14728 Flag_Non_Static_Expr
14729 ("static integer expression required here", N);
14730 return No_Uint;
14731 end if;
14732 end Static_Integer;
14734 --------------------------
14735 -- Statically_Different --
14736 --------------------------
14738 function Statically_Different (E1, E2 : Node_Id) return Boolean is
14739 R1 : constant Node_Id := Get_Referenced_Object (E1);
14740 R2 : constant Node_Id := Get_Referenced_Object (E2);
14741 begin
14742 return Is_Entity_Name (R1)
14743 and then Is_Entity_Name (R2)
14744 and then Entity (R1) /= Entity (R2)
14745 and then not Is_Formal (Entity (R1))
14746 and then not Is_Formal (Entity (R2));
14747 end Statically_Different;
14749 --------------------------------------
14750 -- Subject_To_Loop_Entry_Attributes --
14751 --------------------------------------
14753 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is
14754 Stmt : Node_Id;
14756 begin
14757 Stmt := N;
14759 -- The expansion mechanism transform a loop subject to at least one
14760 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
14761 -- the conditional part.
14763 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
14764 and then Nkind (Original_Node (N)) = N_Loop_Statement
14765 then
14766 Stmt := Original_Node (N);
14767 end if;
14769 return
14770 Nkind (Stmt) = N_Loop_Statement
14771 and then Present (Identifier (Stmt))
14772 and then Present (Entity (Identifier (Stmt)))
14773 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
14774 end Subject_To_Loop_Entry_Attributes;
14776 -----------------------------
14777 -- Subprogram_Access_Level --
14778 -----------------------------
14780 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
14781 begin
14782 if Present (Alias (Subp)) then
14783 return Subprogram_Access_Level (Alias (Subp));
14784 else
14785 return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
14786 end if;
14787 end Subprogram_Access_Level;
14789 -------------------------------
14790 -- Support_Atomic_Primitives --
14791 -------------------------------
14793 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is
14794 Size : Int;
14796 begin
14797 -- Verify the alignment of Typ is known
14799 if not Known_Alignment (Typ) then
14800 return False;
14801 end if;
14803 if Known_Static_Esize (Typ) then
14804 Size := UI_To_Int (Esize (Typ));
14806 -- If the Esize (Object_Size) is unknown at compile time, look at the
14807 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
14809 elsif Known_Static_RM_Size (Typ) then
14810 Size := UI_To_Int (RM_Size (Typ));
14812 -- Otherwise, the size is considered to be unknown.
14814 else
14815 return False;
14816 end if;
14818 -- Check that the size of the component is 8, 16, 32 or 64 bits and that
14819 -- Typ is properly aligned.
14821 case Size is
14822 when 8 | 16 | 32 | 64 =>
14823 return Size = UI_To_Int (Alignment (Typ)) * 8;
14824 when others =>
14825 return False;
14826 end case;
14827 end Support_Atomic_Primitives;
14829 -----------------
14830 -- Trace_Scope --
14831 -----------------
14833 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
14834 begin
14835 if Debug_Flag_W then
14836 for J in 0 .. Scope_Stack.Last loop
14837 Write_Str (" ");
14838 end loop;
14840 Write_Str (Msg);
14841 Write_Name (Chars (E));
14842 Write_Str (" from ");
14843 Write_Location (Sloc (N));
14844 Write_Eol;
14845 end if;
14846 end Trace_Scope;
14848 -----------------------
14849 -- Transfer_Entities --
14850 -----------------------
14852 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
14853 Ent : Entity_Id := First_Entity (From);
14855 begin
14856 if No (Ent) then
14857 return;
14858 end if;
14860 if (Last_Entity (To)) = Empty then
14861 Set_First_Entity (To, Ent);
14862 else
14863 Set_Next_Entity (Last_Entity (To), Ent);
14864 end if;
14866 Set_Last_Entity (To, Last_Entity (From));
14868 while Present (Ent) loop
14869 Set_Scope (Ent, To);
14871 if not Is_Public (Ent) then
14872 Set_Public_Status (Ent);
14874 if Is_Public (Ent)
14875 and then Ekind (Ent) = E_Record_Subtype
14877 then
14878 -- The components of the propagated Itype must be public
14879 -- as well.
14881 declare
14882 Comp : Entity_Id;
14883 begin
14884 Comp := First_Entity (Ent);
14885 while Present (Comp) loop
14886 Set_Is_Public (Comp);
14887 Next_Entity (Comp);
14888 end loop;
14889 end;
14890 end if;
14891 end if;
14893 Next_Entity (Ent);
14894 end loop;
14896 Set_First_Entity (From, Empty);
14897 Set_Last_Entity (From, Empty);
14898 end Transfer_Entities;
14900 -----------------------
14901 -- Type_Access_Level --
14902 -----------------------
14904 function Type_Access_Level (Typ : Entity_Id) return Uint is
14905 Btyp : Entity_Id;
14907 begin
14908 Btyp := Base_Type (Typ);
14910 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
14911 -- simply use the level where the type is declared. This is true for
14912 -- stand-alone object declarations, and for anonymous access types
14913 -- associated with components the level is the same as that of the
14914 -- enclosing composite type. However, special treatment is needed for
14915 -- the cases of access parameters, return objects of an anonymous access
14916 -- type, and, in Ada 95, access discriminants of limited types.
14918 if Ekind (Btyp) in Access_Kind then
14919 if Ekind (Btyp) = E_Anonymous_Access_Type then
14921 -- If the type is a nonlocal anonymous access type (such as for
14922 -- an access parameter) we treat it as being declared at the
14923 -- library level to ensure that names such as X.all'access don't
14924 -- fail static accessibility checks.
14926 if not Is_Local_Anonymous_Access (Typ) then
14927 return Scope_Depth (Standard_Standard);
14929 -- If this is a return object, the accessibility level is that of
14930 -- the result subtype of the enclosing function. The test here is
14931 -- little complicated, because we have to account for extended
14932 -- return statements that have been rewritten as blocks, in which
14933 -- case we have to find and the Is_Return_Object attribute of the
14934 -- itype's associated object. It would be nice to find a way to
14935 -- simplify this test, but it doesn't seem worthwhile to add a new
14936 -- flag just for purposes of this test. ???
14938 elsif Ekind (Scope (Btyp)) = E_Return_Statement
14939 or else
14940 (Is_Itype (Btyp)
14941 and then Nkind (Associated_Node_For_Itype (Btyp)) =
14942 N_Object_Declaration
14943 and then Is_Return_Object
14944 (Defining_Identifier
14945 (Associated_Node_For_Itype (Btyp))))
14946 then
14947 declare
14948 Scop : Entity_Id;
14950 begin
14951 Scop := Scope (Scope (Btyp));
14952 while Present (Scop) loop
14953 exit when Ekind (Scop) = E_Function;
14954 Scop := Scope (Scop);
14955 end loop;
14957 -- Treat the return object's type as having the level of the
14958 -- function's result subtype (as per RM05-6.5(5.3/2)).
14960 return Type_Access_Level (Etype (Scop));
14961 end;
14962 end if;
14963 end if;
14965 Btyp := Root_Type (Btyp);
14967 -- The accessibility level of anonymous access types associated with
14968 -- discriminants is that of the current instance of the type, and
14969 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
14971 -- AI-402: access discriminants have accessibility based on the
14972 -- object rather than the type in Ada 2005, so the above paragraph
14973 -- doesn't apply.
14975 -- ??? Needs completion with rules from AI-416
14977 if Ada_Version <= Ada_95
14978 and then Ekind (Typ) = E_Anonymous_Access_Type
14979 and then Present (Associated_Node_For_Itype (Typ))
14980 and then Nkind (Associated_Node_For_Itype (Typ)) =
14981 N_Discriminant_Specification
14982 then
14983 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
14984 end if;
14985 end if;
14987 -- Return library level for a generic formal type. This is done because
14988 -- RM(10.3.2) says that "The statically deeper relationship does not
14989 -- apply to ... a descendant of a generic formal type". Rather than
14990 -- checking at each point where a static accessibility check is
14991 -- performed to see if we are dealing with a formal type, this rule is
14992 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
14993 -- return extreme values for a formal type; Deepest_Type_Access_Level
14994 -- returns Int'Last. By calling the appropriate function from among the
14995 -- two, we ensure that the static accessibility check will pass if we
14996 -- happen to run into a formal type. More specifically, we should call
14997 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
14998 -- call occurs as part of a static accessibility check and the error
14999 -- case is the case where the type's level is too shallow (as opposed
15000 -- to too deep).
15002 if Is_Generic_Type (Root_Type (Btyp)) then
15003 return Scope_Depth (Standard_Standard);
15004 end if;
15006 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
15007 end Type_Access_Level;
15009 ------------------------------------
15010 -- Type_Without_Stream_Operation --
15011 ------------------------------------
15013 function Type_Without_Stream_Operation
15014 (T : Entity_Id;
15015 Op : TSS_Name_Type := TSS_Null) return Entity_Id
15017 BT : constant Entity_Id := Base_Type (T);
15018 Op_Missing : Boolean;
15020 begin
15021 if not Restriction_Active (No_Default_Stream_Attributes) then
15022 return Empty;
15023 end if;
15025 if Is_Elementary_Type (T) then
15026 if Op = TSS_Null then
15027 Op_Missing :=
15028 No (TSS (BT, TSS_Stream_Read))
15029 or else No (TSS (BT, TSS_Stream_Write));
15031 else
15032 Op_Missing := No (TSS (BT, Op));
15033 end if;
15035 if Op_Missing then
15036 return T;
15037 else
15038 return Empty;
15039 end if;
15041 elsif Is_Array_Type (T) then
15042 return Type_Without_Stream_Operation (Component_Type (T), Op);
15044 elsif Is_Record_Type (T) then
15045 declare
15046 Comp : Entity_Id;
15047 C_Typ : Entity_Id;
15049 begin
15050 Comp := First_Component (T);
15051 while Present (Comp) loop
15052 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
15054 if Present (C_Typ) then
15055 return C_Typ;
15056 end if;
15058 Next_Component (Comp);
15059 end loop;
15061 return Empty;
15062 end;
15064 elsif Is_Private_Type (T)
15065 and then Present (Full_View (T))
15066 then
15067 return Type_Without_Stream_Operation (Full_View (T), Op);
15068 else
15069 return Empty;
15070 end if;
15071 end Type_Without_Stream_Operation;
15073 ----------------------------
15074 -- Unique_Defining_Entity --
15075 ----------------------------
15077 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
15078 begin
15079 return Unique_Entity (Defining_Entity (N));
15080 end Unique_Defining_Entity;
15082 -------------------
15083 -- Unique_Entity --
15084 -------------------
15086 function Unique_Entity (E : Entity_Id) return Entity_Id is
15087 U : Entity_Id := E;
15088 P : Node_Id;
15090 begin
15091 case Ekind (E) is
15092 when E_Constant =>
15093 if Present (Full_View (E)) then
15094 U := Full_View (E);
15095 end if;
15097 when Type_Kind =>
15098 if Present (Full_View (E)) then
15099 U := Full_View (E);
15100 end if;
15102 when E_Package_Body =>
15103 P := Parent (E);
15105 if Nkind (P) = N_Defining_Program_Unit_Name then
15106 P := Parent (P);
15107 end if;
15109 U := Corresponding_Spec (P);
15111 when E_Subprogram_Body =>
15112 P := Parent (E);
15114 if Nkind (P) = N_Defining_Program_Unit_Name then
15115 P := Parent (P);
15116 end if;
15118 P := Parent (P);
15120 if Nkind (P) = N_Subprogram_Body_Stub then
15121 if Present (Library_Unit (P)) then
15123 -- Get to the function or procedure (generic) entity through
15124 -- the body entity.
15126 U :=
15127 Unique_Entity (Defining_Entity (Get_Body_From_Stub (P)));
15128 end if;
15129 else
15130 U := Corresponding_Spec (P);
15131 end if;
15133 when Formal_Kind =>
15134 if Present (Spec_Entity (E)) then
15135 U := Spec_Entity (E);
15136 end if;
15138 when others =>
15139 null;
15140 end case;
15142 return U;
15143 end Unique_Entity;
15145 -----------------
15146 -- Unique_Name --
15147 -----------------
15149 function Unique_Name (E : Entity_Id) return String is
15151 -- Names of E_Subprogram_Body or E_Package_Body entities are not
15152 -- reliable, as they may not include the overloading suffix. Instead,
15153 -- when looking for the name of E or one of its enclosing scope, we get
15154 -- the name of the corresponding Unique_Entity.
15156 function Get_Scoped_Name (E : Entity_Id) return String;
15157 -- Return the name of E prefixed by all the names of the scopes to which
15158 -- E belongs, except for Standard.
15160 ---------------------
15161 -- Get_Scoped_Name --
15162 ---------------------
15164 function Get_Scoped_Name (E : Entity_Id) return String is
15165 Name : constant String := Get_Name_String (Chars (E));
15166 begin
15167 if Has_Fully_Qualified_Name (E)
15168 or else Scope (E) = Standard_Standard
15169 then
15170 return Name;
15171 else
15172 return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name;
15173 end if;
15174 end Get_Scoped_Name;
15176 -- Start of processing for Unique_Name
15178 begin
15179 if E = Standard_Standard then
15180 return Get_Name_String (Name_Standard);
15182 elsif Scope (E) = Standard_Standard
15183 and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
15184 then
15185 return Get_Name_String (Name_Standard) & "__" &
15186 Get_Name_String (Chars (E));
15188 elsif Ekind (E) = E_Enumeration_Literal then
15189 return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
15191 else
15192 return Get_Scoped_Name (Unique_Entity (E));
15193 end if;
15194 end Unique_Name;
15196 ---------------------
15197 -- Unit_Is_Visible --
15198 ---------------------
15200 function Unit_Is_Visible (U : Entity_Id) return Boolean is
15201 Curr : constant Node_Id := Cunit (Current_Sem_Unit);
15202 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
15204 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
15205 -- For a child unit, check whether unit appears in a with_clause
15206 -- of a parent.
15208 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
15209 -- Scan the context clause of one compilation unit looking for a
15210 -- with_clause for the unit in question.
15212 ----------------------------
15213 -- Unit_In_Parent_Context --
15214 ----------------------------
15216 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
15217 begin
15218 if Unit_In_Context (Par_Unit) then
15219 return True;
15221 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
15222 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
15224 else
15225 return False;
15226 end if;
15227 end Unit_In_Parent_Context;
15229 ---------------------
15230 -- Unit_In_Context --
15231 ---------------------
15233 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
15234 Clause : Node_Id;
15236 begin
15237 Clause := First (Context_Items (Comp_Unit));
15238 while Present (Clause) loop
15239 if Nkind (Clause) = N_With_Clause then
15240 if Library_Unit (Clause) = U then
15241 return True;
15243 -- The with_clause may denote a renaming of the unit we are
15244 -- looking for, eg. Text_IO which renames Ada.Text_IO.
15246 elsif
15247 Renamed_Entity (Entity (Name (Clause))) =
15248 Defining_Entity (Unit (U))
15249 then
15250 return True;
15251 end if;
15252 end if;
15254 Next (Clause);
15255 end loop;
15257 return False;
15258 end Unit_In_Context;
15260 -- Start of processing for Unit_Is_Visible
15262 begin
15263 -- The currrent unit is directly visible
15265 if Curr = U then
15266 return True;
15268 elsif Unit_In_Context (Curr) then
15269 return True;
15271 -- If the current unit is a body, check the context of the spec
15273 elsif Nkind (Unit (Curr)) = N_Package_Body
15274 or else
15275 (Nkind (Unit (Curr)) = N_Subprogram_Body
15276 and then not Acts_As_Spec (Unit (Curr)))
15277 then
15278 if Unit_In_Context (Library_Unit (Curr)) then
15279 return True;
15280 end if;
15281 end if;
15283 -- If the spec is a child unit, examine the parents
15285 if Is_Child_Unit (Curr_Entity) then
15286 if Nkind (Unit (Curr)) in N_Unit_Body then
15287 return
15288 Unit_In_Parent_Context
15289 (Parent_Spec (Unit (Library_Unit (Curr))));
15290 else
15291 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
15292 end if;
15294 else
15295 return False;
15296 end if;
15297 end Unit_Is_Visible;
15299 ------------------------------
15300 -- Universal_Interpretation --
15301 ------------------------------
15303 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
15304 Index : Interp_Index;
15305 It : Interp;
15307 begin
15308 -- The argument may be a formal parameter of an operator or subprogram
15309 -- with multiple interpretations, or else an expression for an actual.
15311 if Nkind (Opnd) = N_Defining_Identifier
15312 or else not Is_Overloaded (Opnd)
15313 then
15314 if Etype (Opnd) = Universal_Integer
15315 or else Etype (Opnd) = Universal_Real
15316 then
15317 return Etype (Opnd);
15318 else
15319 return Empty;
15320 end if;
15322 else
15323 Get_First_Interp (Opnd, Index, It);
15324 while Present (It.Typ) loop
15325 if It.Typ = Universal_Integer
15326 or else It.Typ = Universal_Real
15327 then
15328 return It.Typ;
15329 end if;
15331 Get_Next_Interp (Index, It);
15332 end loop;
15334 return Empty;
15335 end if;
15336 end Universal_Interpretation;
15338 ---------------
15339 -- Unqualify --
15340 ---------------
15342 function Unqualify (Expr : Node_Id) return Node_Id is
15343 begin
15344 -- Recurse to handle unlikely case of multiple levels of qualification
15346 if Nkind (Expr) = N_Qualified_Expression then
15347 return Unqualify (Expression (Expr));
15349 -- Normal case, not a qualified expression
15351 else
15352 return Expr;
15353 end if;
15354 end Unqualify;
15356 -----------------------
15357 -- Visible_Ancestors --
15358 -----------------------
15360 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
15361 List_1 : Elist_Id;
15362 List_2 : Elist_Id;
15363 Elmt : Elmt_Id;
15365 begin
15366 pragma Assert (Is_Record_Type (Typ)
15367 and then Is_Tagged_Type (Typ));
15369 -- Collect all the parents and progenitors of Typ. If the full-view of
15370 -- private parents and progenitors is available then it is used to
15371 -- generate the list of visible ancestors; otherwise their partial
15372 -- view is added to the resulting list.
15374 Collect_Parents
15375 (T => Typ,
15376 List => List_1,
15377 Use_Full_View => True);
15379 Collect_Interfaces
15380 (T => Typ,
15381 Ifaces_List => List_2,
15382 Exclude_Parents => True,
15383 Use_Full_View => True);
15385 -- Join the two lists. Avoid duplications because an interface may
15386 -- simultaneously be parent and progenitor of a type.
15388 Elmt := First_Elmt (List_2);
15389 while Present (Elmt) loop
15390 Append_Unique_Elmt (Node (Elmt), List_1);
15391 Next_Elmt (Elmt);
15392 end loop;
15394 return List_1;
15395 end Visible_Ancestors;
15397 ----------------------
15398 -- Within_Init_Proc --
15399 ----------------------
15401 function Within_Init_Proc return Boolean is
15402 S : Entity_Id;
15404 begin
15405 S := Current_Scope;
15406 while not Is_Overloadable (S) loop
15407 if S = Standard_Standard then
15408 return False;
15409 else
15410 S := Scope (S);
15411 end if;
15412 end loop;
15414 return Is_Init_Proc (S);
15415 end Within_Init_Proc;
15417 ----------------
15418 -- Wrong_Type --
15419 ----------------
15421 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
15422 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
15423 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
15425 Matching_Field : Entity_Id;
15426 -- Entity to give a more precise suggestion on how to write a one-
15427 -- element positional aggregate.
15429 function Has_One_Matching_Field return Boolean;
15430 -- Determines if Expec_Type is a record type with a single component or
15431 -- discriminant whose type matches the found type or is one dimensional
15432 -- array whose component type matches the found type. In the case of
15433 -- one discriminant, we ignore the variant parts. That's not accurate,
15434 -- but good enough for the warning.
15436 ----------------------------
15437 -- Has_One_Matching_Field --
15438 ----------------------------
15440 function Has_One_Matching_Field return Boolean is
15441 E : Entity_Id;
15443 begin
15444 Matching_Field := Empty;
15446 if Is_Array_Type (Expec_Type)
15447 and then Number_Dimensions (Expec_Type) = 1
15448 and then
15449 Covers (Etype (Component_Type (Expec_Type)), Found_Type)
15450 then
15451 -- Use type name if available. This excludes multidimensional
15452 -- arrays and anonymous arrays.
15454 if Comes_From_Source (Expec_Type) then
15455 Matching_Field := Expec_Type;
15457 -- For an assignment, use name of target
15459 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
15460 and then Is_Entity_Name (Name (Parent (Expr)))
15461 then
15462 Matching_Field := Entity (Name (Parent (Expr)));
15463 end if;
15465 return True;
15467 elsif not Is_Record_Type (Expec_Type) then
15468 return False;
15470 else
15471 E := First_Entity (Expec_Type);
15472 loop
15473 if No (E) then
15474 return False;
15476 elsif not Ekind_In (E, E_Discriminant, E_Component)
15477 or else Nam_In (Chars (E), Name_uTag, Name_uParent)
15478 then
15479 Next_Entity (E);
15481 else
15482 exit;
15483 end if;
15484 end loop;
15486 if not Covers (Etype (E), Found_Type) then
15487 return False;
15489 elsif Present (Next_Entity (E))
15490 and then (Ekind (E) = E_Component
15491 or else Ekind (Next_Entity (E)) = E_Discriminant)
15492 then
15493 return False;
15495 else
15496 Matching_Field := E;
15497 return True;
15498 end if;
15499 end if;
15500 end Has_One_Matching_Field;
15502 -- Start of processing for Wrong_Type
15504 begin
15505 -- Don't output message if either type is Any_Type, or if a message
15506 -- has already been posted for this node. We need to do the latter
15507 -- check explicitly (it is ordinarily done in Errout), because we
15508 -- are using ! to force the output of the error messages.
15510 if Expec_Type = Any_Type
15511 or else Found_Type = Any_Type
15512 or else Error_Posted (Expr)
15513 then
15514 return;
15516 -- If one of the types is a Taft-Amendment type and the other it its
15517 -- completion, it must be an illegal use of a TAT in the spec, for
15518 -- which an error was already emitted. Avoid cascaded errors.
15520 elsif Is_Incomplete_Type (Expec_Type)
15521 and then Has_Completion_In_Body (Expec_Type)
15522 and then Full_View (Expec_Type) = Etype (Expr)
15523 then
15524 return;
15526 elsif Is_Incomplete_Type (Etype (Expr))
15527 and then Has_Completion_In_Body (Etype (Expr))
15528 and then Full_View (Etype (Expr)) = Expec_Type
15529 then
15530 return;
15532 -- In an instance, there is an ongoing problem with completion of
15533 -- type derived from private types. Their structure is what Gigi
15534 -- expects, but the Etype is the parent type rather than the
15535 -- derived private type itself. Do not flag error in this case. The
15536 -- private completion is an entity without a parent, like an Itype.
15537 -- Similarly, full and partial views may be incorrect in the instance.
15538 -- There is no simple way to insure that it is consistent ???
15540 elsif In_Instance then
15541 if Etype (Etype (Expr)) = Etype (Expected_Type)
15542 and then
15543 (Has_Private_Declaration (Expected_Type)
15544 or else Has_Private_Declaration (Etype (Expr)))
15545 and then No (Parent (Expected_Type))
15546 then
15547 return;
15548 end if;
15549 end if;
15551 -- An interesting special check. If the expression is parenthesized
15552 -- and its type corresponds to the type of the sole component of the
15553 -- expected record type, or to the component type of the expected one
15554 -- dimensional array type, then assume we have a bad aggregate attempt.
15556 if Nkind (Expr) in N_Subexpr
15557 and then Paren_Count (Expr) /= 0
15558 and then Has_One_Matching_Field
15559 then
15560 Error_Msg_N ("positional aggregate cannot have one component", Expr);
15561 if Present (Matching_Field) then
15562 if Is_Array_Type (Expec_Type) then
15563 Error_Msg_NE
15564 ("\write instead `&''First ='> ...`", Expr, Matching_Field);
15566 else
15567 Error_Msg_NE
15568 ("\write instead `& ='> ...`", Expr, Matching_Field);
15569 end if;
15570 end if;
15572 -- Another special check, if we are looking for a pool-specific access
15573 -- type and we found an E_Access_Attribute_Type, then we have the case
15574 -- of an Access attribute being used in a context which needs a pool-
15575 -- specific type, which is never allowed. The one extra check we make
15576 -- is that the expected designated type covers the Found_Type.
15578 elsif Is_Access_Type (Expec_Type)
15579 and then Ekind (Found_Type) = E_Access_Attribute_Type
15580 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
15581 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
15582 and then Covers
15583 (Designated_Type (Expec_Type), Designated_Type (Found_Type))
15584 then
15585 Error_Msg_N -- CODEFIX
15586 ("result must be general access type!", Expr);
15587 Error_Msg_NE -- CODEFIX
15588 ("add ALL to }!", Expr, Expec_Type);
15590 -- Another special check, if the expected type is an integer type,
15591 -- but the expression is of type System.Address, and the parent is
15592 -- an addition or subtraction operation whose left operand is the
15593 -- expression in question and whose right operand is of an integral
15594 -- type, then this is an attempt at address arithmetic, so give
15595 -- appropriate message.
15597 elsif Is_Integer_Type (Expec_Type)
15598 and then Is_RTE (Found_Type, RE_Address)
15599 and then (Nkind (Parent (Expr)) = N_Op_Add
15600 or else
15601 Nkind (Parent (Expr)) = N_Op_Subtract)
15602 and then Expr = Left_Opnd (Parent (Expr))
15603 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
15604 then
15605 Error_Msg_N
15606 ("address arithmetic not predefined in package System",
15607 Parent (Expr));
15608 Error_Msg_N
15609 ("\possible missing with/use of System.Storage_Elements",
15610 Parent (Expr));
15611 return;
15613 -- If the expected type is an anonymous access type, as for access
15614 -- parameters and discriminants, the error is on the designated types.
15616 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
15617 if Comes_From_Source (Expec_Type) then
15618 Error_Msg_NE ("expected}!", Expr, Expec_Type);
15619 else
15620 Error_Msg_NE
15621 ("expected an access type with designated}",
15622 Expr, Designated_Type (Expec_Type));
15623 end if;
15625 if Is_Access_Type (Found_Type)
15626 and then not Comes_From_Source (Found_Type)
15627 then
15628 Error_Msg_NE
15629 ("\\found an access type with designated}!",
15630 Expr, Designated_Type (Found_Type));
15631 else
15632 if From_Limited_With (Found_Type) then
15633 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
15634 Error_Msg_Qual_Level := 99;
15635 Error_Msg_NE -- CODEFIX
15636 ("\\missing `WITH &;", Expr, Scope (Found_Type));
15637 Error_Msg_Qual_Level := 0;
15638 else
15639 Error_Msg_NE ("found}!", Expr, Found_Type);
15640 end if;
15641 end if;
15643 -- Normal case of one type found, some other type expected
15645 else
15646 -- If the names of the two types are the same, see if some number
15647 -- of levels of qualification will help. Don't try more than three
15648 -- levels, and if we get to standard, it's no use (and probably
15649 -- represents an error in the compiler) Also do not bother with
15650 -- internal scope names.
15652 declare
15653 Expec_Scope : Entity_Id;
15654 Found_Scope : Entity_Id;
15656 begin
15657 Expec_Scope := Expec_Type;
15658 Found_Scope := Found_Type;
15660 for Levels in Int range 0 .. 3 loop
15661 if Chars (Expec_Scope) /= Chars (Found_Scope) then
15662 Error_Msg_Qual_Level := Levels;
15663 exit;
15664 end if;
15666 Expec_Scope := Scope (Expec_Scope);
15667 Found_Scope := Scope (Found_Scope);
15669 exit when Expec_Scope = Standard_Standard
15670 or else Found_Scope = Standard_Standard
15671 or else not Comes_From_Source (Expec_Scope)
15672 or else not Comes_From_Source (Found_Scope);
15673 end loop;
15674 end;
15676 if Is_Record_Type (Expec_Type)
15677 and then Present (Corresponding_Remote_Type (Expec_Type))
15678 then
15679 Error_Msg_NE ("expected}!", Expr,
15680 Corresponding_Remote_Type (Expec_Type));
15681 else
15682 Error_Msg_NE ("expected}!", Expr, Expec_Type);
15683 end if;
15685 if Is_Entity_Name (Expr)
15686 and then Is_Package_Or_Generic_Package (Entity (Expr))
15687 then
15688 Error_Msg_N ("\\found package name!", Expr);
15690 elsif Is_Entity_Name (Expr)
15691 and then
15692 (Ekind (Entity (Expr)) = E_Procedure
15693 or else
15694 Ekind (Entity (Expr)) = E_Generic_Procedure)
15695 then
15696 if Ekind (Expec_Type) = E_Access_Subprogram_Type then
15697 Error_Msg_N
15698 ("found procedure name, possibly missing Access attribute!",
15699 Expr);
15700 else
15701 Error_Msg_N
15702 ("\\found procedure name instead of function!", Expr);
15703 end if;
15705 elsif Nkind (Expr) = N_Function_Call
15706 and then Ekind (Expec_Type) = E_Access_Subprogram_Type
15707 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
15708 and then No (Parameter_Associations (Expr))
15709 then
15710 Error_Msg_N
15711 ("found function name, possibly missing Access attribute!",
15712 Expr);
15714 -- Catch common error: a prefix or infix operator which is not
15715 -- directly visible because the type isn't.
15717 elsif Nkind (Expr) in N_Op
15718 and then Is_Overloaded (Expr)
15719 and then not Is_Immediately_Visible (Expec_Type)
15720 and then not Is_Potentially_Use_Visible (Expec_Type)
15721 and then not In_Use (Expec_Type)
15722 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
15723 then
15724 Error_Msg_N
15725 ("operator of the type is not directly visible!", Expr);
15727 elsif Ekind (Found_Type) = E_Void
15728 and then Present (Parent (Found_Type))
15729 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
15730 then
15731 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
15733 else
15734 Error_Msg_NE ("\\found}!", Expr, Found_Type);
15735 end if;
15737 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
15738 -- of the same modular type, and (M1 and M2) = 0 was intended.
15740 if Expec_Type = Standard_Boolean
15741 and then Is_Modular_Integer_Type (Found_Type)
15742 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
15743 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
15744 then
15745 declare
15746 Op : constant Node_Id := Right_Opnd (Parent (Expr));
15747 L : constant Node_Id := Left_Opnd (Op);
15748 R : constant Node_Id := Right_Opnd (Op);
15749 begin
15750 -- The case for the message is when the left operand of the
15751 -- comparison is the same modular type, or when it is an
15752 -- integer literal (or other universal integer expression),
15753 -- which would have been typed as the modular type if the
15754 -- parens had been there.
15756 if (Etype (L) = Found_Type
15757 or else
15758 Etype (L) = Universal_Integer)
15759 and then Is_Integer_Type (Etype (R))
15760 then
15761 Error_Msg_N
15762 ("\\possible missing parens for modular operation", Expr);
15763 end if;
15764 end;
15765 end if;
15767 -- Reset error message qualification indication
15769 Error_Msg_Qual_Level := 0;
15770 end if;
15771 end Wrong_Type;
15773 end Sem_Util;