?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / sem_util.adb
blobdcad44f1bbaedb1195e9a7a0d3a61e4cdb03ed23
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 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Casing; use Casing;
28 with Checks; use Checks;
29 with Debug; use Debug;
30 with Errout; use Errout;
31 with Elists; use Elists;
32 with Exp_Ch11; use Exp_Ch11;
33 with Exp_Disp; use Exp_Disp;
34 with Exp_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;
64
65 with GNAT.HTable; use GNAT.HTable;
66
67 package body Sem_Util is
68
69 ----------------------------------------
70 -- Global_Variables for New_Copy_Tree --
71 ----------------------------------------
72
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.
77
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.
82
83 NCT_Hash_Tables_Used : Boolean := False;
84 -- Set to True if hash tables are in use
85
86 NCT_Table_Entries : Nat := 0;
87 -- Count entries in table to see if threshold is reached
88
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.
94
95 subtype NCT_Header_Num is Int range 0 .. 511;
96 -- Defines range of headers in hash tables (512 headers)
97
98 -----------------------
99 -- Local Subprograms --
100 -----------------------
101
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.
109
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.
115
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.
119
120 ------------------------------
121 -- Abstract_Interface_List --
122 ------------------------------
123
124 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
125 Nod : Node_Id;
126
127 begin
128 if Is_Concurrent_Type (Typ) then
129
130 -- If we are dealing with a synchronized subtype, go to the base
131 -- type, whose declaration has the interface list.
132
133 -- Shouldn't this be Declaration_Node???
134
135 Nod := Parent (Base_Type (Typ));
136
137 if Nkind (Nod) = N_Full_Type_Declaration then
138 return Empty_List;
139 end if;
140
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));
144
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)));
151
152 -- If the full-view is not available we cannot do anything else
153 -- here (the source has errors).
154
155 else
156 return Empty_List;
157 end if;
158
159 -- Support for generic formals with interfaces is still missing ???
160
161 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
162 return Empty_List;
163
164 else
165 pragma Assert
166 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
167 Nod := Parent (Typ);
168 end if;
169
170 elsif Ekind (Typ) = E_Record_Subtype then
171 Nod := Type_Definition (Parent (Etype (Typ)));
172
173 elsif Ekind (Typ) = E_Record_Subtype_With_Private then
174
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.
178
179 return Abstract_Interface_List (Etype (Typ));
180
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;
188
189 return Interface_List (Nod);
190 end Abstract_Interface_List;
191
192 --------------------------------
193 -- Add_Access_Type_To_Process --
194 --------------------------------
195
196 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
197 L : Elist_Id;
198
199 begin
200 Ensure_Freeze_Node (E);
201 L := Access_Types_To_Process (Freeze_Node (E));
202
203 if No (L) then
204 L := New_Elmt_List;
205 Set_Access_Types_To_Process (Freeze_Node (E), L);
206 end if;
207
208 Append_Elmt (A, L);
209 end Add_Access_Type_To_Process;
210
211 -----------------------
212 -- Add_Contract_Item --
213 -----------------------
214
215 procedure Add_Contract_Item (Item : Node_Id; Subp_Id : Entity_Id) is
216 Items : constant Node_Id := Contract (Subp_Id);
217 Nam : Name_Id;
218
219 begin
220 if Present (Items) and then Nkind (Item) = N_Pragma then
221 Nam := Pragma_Name (Item);
222
223 if Nam_In (Nam, Name_Precondition, Name_Postcondition) then
224 Set_Next_Pragma (Item, Pre_Post_Conditions (Items));
225 Set_Pre_Post_Conditions (Items, Item);
226
227 elsif Nam_In (Nam, Name_Contract_Cases, Name_Test_Case) then
228 Set_Next_Pragma (Item, Contract_Test_Cases (Items));
229 Set_Contract_Test_Cases (Items, Item);
230
231 elsif Nam_In (Nam, Name_Depends, Name_Global) then
232 Set_Next_Pragma (Item, Classifications (Items));
233 Set_Classifications (Items, Item);
234
235 -- The pragma is not a proper contract item
236
237 else
238 raise Program_Error;
239 end if;
240
241 -- The subprogram has not been properly decorated or the item is illegal
242
243 else
244 raise Program_Error;
245 end if;
246 end Add_Contract_Item;
247
248 ----------------------------
249 -- Add_Global_Declaration --
250 ----------------------------
251
252 procedure Add_Global_Declaration (N : Node_Id) is
253 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
254
255 begin
256 if No (Declarations (Aux_Node)) then
257 Set_Declarations (Aux_Node, New_List);
258 end if;
259
260 Append_To (Declarations (Aux_Node), N);
261 Analyze (N);
262 end Add_Global_Declaration;
263
264 -----------------
265 -- Addressable --
266 -----------------
267
268 -- For now, just 8/16/32/64. but analyze later if AAMP is special???
269
270 function Addressable (V : Uint) return Boolean is
271 begin
272 return V = Uint_8 or else
273 V = Uint_16 or else
274 V = Uint_32 or else
275 V = Uint_64;
276 end Addressable;
277
278 function Addressable (V : Int) return Boolean is
279 begin
280 return V = 8 or else
281 V = 16 or else
282 V = 32 or else
283 V = 64;
284 end Addressable;
285
286 -----------------------
287 -- Alignment_In_Bits --
288 -----------------------
289
290 function Alignment_In_Bits (E : Entity_Id) return Uint is
291 begin
292 return Alignment (E) * System_Storage_Unit;
293 end Alignment_In_Bits;
294
295 ---------------------------------
296 -- Append_Inherited_Subprogram --
297 ---------------------------------
298
299 procedure Append_Inherited_Subprogram (S : Entity_Id) is
300 Par : constant Entity_Id := Alias (S);
301 -- The parent subprogram
302
303 Scop : constant Entity_Id := Scope (Par);
304 -- The scope of definition of the parent subprogram
305
306 Typ : constant Entity_Id := Defining_Entity (Parent (S));
307 -- The derived type of which S is a primitive operation
308
309 Decl : Node_Id;
310 Next_E : Entity_Id;
311
312 begin
313 if Ekind (Current_Scope) = E_Package
314 and then In_Private_Part (Current_Scope)
315 and then Has_Private_Declaration (Typ)
316 and then Is_Tagged_Type (Typ)
317 and then Scop = Current_Scope
318 then
319 -- The inherited operation is available at the earliest place after
320 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only
321 -- relevant for type extensions. If the parent operation appears
322 -- after the type extension, the operation is not visible.
323
324 Decl := First
325 (Visible_Declarations
326 (Specification (Unit_Declaration_Node (Current_Scope))));
327 while Present (Decl) loop
328 if Nkind (Decl) = N_Private_Extension_Declaration
329 and then Defining_Entity (Decl) = Typ
330 then
331 if Sloc (Decl) > Sloc (Par) then
332 Next_E := Next_Entity (Par);
333 Set_Next_Entity (Par, S);
334 Set_Next_Entity (S, Next_E);
335 return;
336
337 else
338 exit;
339 end if;
340 end if;
341
342 Next (Decl);
343 end loop;
344 end if;
345
346 -- If partial view is not a type extension, or it appears before the
347 -- subprogram declaration, insert normally at end of entity list.
348
349 Append_Entity (S, Current_Scope);
350 end Append_Inherited_Subprogram;
351
352 -----------------------------------------
353 -- Apply_Compile_Time_Constraint_Error --
354 -----------------------------------------
355
356 procedure Apply_Compile_Time_Constraint_Error
357 (N : Node_Id;
358 Msg : String;
359 Reason : RT_Exception_Code;
360 Ent : Entity_Id := Empty;
361 Typ : Entity_Id := Empty;
362 Loc : Source_Ptr := No_Location;
363 Rep : Boolean := True;
364 Warn : Boolean := False)
365 is
366 Stat : constant Boolean := Is_Static_Expression (N);
367 R_Stat : constant Node_Id :=
368 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
369 Rtyp : Entity_Id;
370
371 begin
372 if No (Typ) then
373 Rtyp := Etype (N);
374 else
375 Rtyp := Typ;
376 end if;
377
378 Discard_Node
379 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
380
381 if not Rep then
382 return;
383 end if;
384
385 -- Now we replace the node by an N_Raise_Constraint_Error node
386 -- This does not need reanalyzing, so set it as analyzed now.
387
388 Rewrite (N, R_Stat);
389 Set_Analyzed (N, True);
390
391 Set_Etype (N, Rtyp);
392 Set_Raises_Constraint_Error (N);
393
394 -- Now deal with possible local raise handling
395
396 Possible_Local_Raise (N, Standard_Constraint_Error);
397
398 -- If the original expression was marked as static, the result is
399 -- still marked as static, but the Raises_Constraint_Error flag is
400 -- always set so that further static evaluation is not attempted.
401
402 if Stat then
403 Set_Is_Static_Expression (N);
404 end if;
405 end Apply_Compile_Time_Constraint_Error;
406
407 --------------------------------------
408 -- Available_Full_View_Of_Component --
409 --------------------------------------
410
411 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
412 ST : constant Entity_Id := Scope (T);
413 SCT : constant Entity_Id := Scope (Component_Type (T));
414 begin
415 return In_Open_Scopes (ST)
416 and then In_Open_Scopes (SCT)
417 and then Scope_Depth (ST) >= Scope_Depth (SCT);
418 end Available_Full_View_Of_Component;
419
420 -------------------
421 -- Bad_Attribute --
422 -------------------
423
424 procedure Bad_Attribute
425 (N : Node_Id;
426 Nam : Name_Id;
427 Warn : Boolean := False)
428 is
429 begin
430 Error_Msg_Warn := Warn;
431 Error_Msg_N ("unrecognized attribute&<", N);
432
433 -- Check for possible misspelling
434
435 Error_Msg_Name_1 := First_Attribute_Name;
436 while Error_Msg_Name_1 <= Last_Attribute_Name loop
437 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
438 Error_Msg_N -- CODEFIX
439 ("\possible misspelling of %<", N);
440 exit;
441 end if;
442
443 Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
444 end loop;
445 end Bad_Attribute;
446
447 --------------------------------
448 -- Bad_Predicated_Subtype_Use --
449 --------------------------------
450
451 procedure Bad_Predicated_Subtype_Use
452 (Msg : String;
453 N : Node_Id;
454 Typ : Entity_Id;
455 Suggest_Static : Boolean := False)
456 is
457 begin
458 if Has_Predicates (Typ) then
459 if Is_Generic_Actual_Type (Typ) then
460 Error_Msg_FE (Msg & "??", N, Typ);
461 Error_Msg_F ("\Program_Error will be raised at run time??", N);
462 Insert_Action (N,
463 Make_Raise_Program_Error (Sloc (N),
464 Reason => PE_Bad_Predicated_Generic_Type));
465
466 else
467 Error_Msg_FE (Msg, N, Typ);
468 end if;
469
470 -- Emit an optional suggestion on how to remedy the error if the
471 -- context warrants it.
472
473 if Suggest_Static and then Present (Static_Predicate (Typ)) then
474 Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
475 end if;
476 end if;
477 end Bad_Predicated_Subtype_Use;
478
479 --------------------------
480 -- Build_Actual_Subtype --
481 --------------------------
482
483 function Build_Actual_Subtype
484 (T : Entity_Id;
485 N : Node_Or_Entity_Id) return Node_Id
486 is
487 Loc : Source_Ptr;
488 -- Normally Sloc (N), but may point to corresponding body in some cases
489
490 Constraints : List_Id;
491 Decl : Node_Id;
492 Discr : Entity_Id;
493 Hi : Node_Id;
494 Lo : Node_Id;
495 Subt : Entity_Id;
496 Disc_Type : Entity_Id;
497 Obj : Node_Id;
498
499 begin
500 Loc := Sloc (N);
501
502 if Nkind (N) = N_Defining_Identifier then
503 Obj := New_Reference_To (N, Loc);
504
505 -- If this is a formal parameter of a subprogram declaration, and
506 -- we are compiling the body, we want the declaration for the
507 -- actual subtype to carry the source position of the body, to
508 -- prevent anomalies in gdb when stepping through the code.
509
510 if Is_Formal (N) then
511 declare
512 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
513 begin
514 if Nkind (Decl) = N_Subprogram_Declaration
515 and then Present (Corresponding_Body (Decl))
516 then
517 Loc := Sloc (Corresponding_Body (Decl));
518 end if;
519 end;
520 end if;
521
522 else
523 Obj := N;
524 end if;
525
526 if Is_Array_Type (T) then
527 Constraints := New_List;
528 for J in 1 .. Number_Dimensions (T) loop
529
530 -- Build an array subtype declaration with the nominal subtype and
531 -- the bounds of the actual. Add the declaration in front of the
532 -- local declarations for the subprogram, for analysis before any
533 -- reference to the formal in the body.
534
535 Lo :=
536 Make_Attribute_Reference (Loc,
537 Prefix =>
538 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
539 Attribute_Name => Name_First,
540 Expressions => New_List (
541 Make_Integer_Literal (Loc, J)));
542
543 Hi :=
544 Make_Attribute_Reference (Loc,
545 Prefix =>
546 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
547 Attribute_Name => Name_Last,
548 Expressions => New_List (
549 Make_Integer_Literal (Loc, J)));
550
551 Append (Make_Range (Loc, Lo, Hi), Constraints);
552 end loop;
553
554 -- If the type has unknown discriminants there is no constrained
555 -- subtype to build. This is never called for a formal or for a
556 -- lhs, so returning the type is ok ???
557
558 elsif Has_Unknown_Discriminants (T) then
559 return T;
560
561 else
562 Constraints := New_List;
563
564 -- Type T is a generic derived type, inherit the discriminants from
565 -- the parent type.
566
567 if Is_Private_Type (T)
568 and then No (Full_View (T))
569
570 -- T was flagged as an error if it was declared as a formal
571 -- derived type with known discriminants. In this case there
572 -- is no need to look at the parent type since T already carries
573 -- its own discriminants.
574
575 and then not Error_Posted (T)
576 then
577 Disc_Type := Etype (Base_Type (T));
578 else
579 Disc_Type := T;
580 end if;
581
582 Discr := First_Discriminant (Disc_Type);
583 while Present (Discr) loop
584 Append_To (Constraints,
585 Make_Selected_Component (Loc,
586 Prefix =>
587 Duplicate_Subexpr_No_Checks (Obj),
588 Selector_Name => New_Occurrence_Of (Discr, Loc)));
589 Next_Discriminant (Discr);
590 end loop;
591 end if;
592
593 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
594 Set_Is_Internal (Subt);
595
596 Decl :=
597 Make_Subtype_Declaration (Loc,
598 Defining_Identifier => Subt,
599 Subtype_Indication =>
600 Make_Subtype_Indication (Loc,
601 Subtype_Mark => New_Reference_To (T, Loc),
602 Constraint =>
603 Make_Index_Or_Discriminant_Constraint (Loc,
604 Constraints => Constraints)));
605
606 Mark_Rewrite_Insertion (Decl);
607 return Decl;
608 end Build_Actual_Subtype;
609
610 ---------------------------------------
611 -- Build_Actual_Subtype_Of_Component --
612 ---------------------------------------
613
614 function Build_Actual_Subtype_Of_Component
615 (T : Entity_Id;
616 N : Node_Id) return Node_Id
617 is
618 Loc : constant Source_Ptr := Sloc (N);
619 P : constant Node_Id := Prefix (N);
620 D : Elmt_Id;
621 Id : Node_Id;
622 Index_Typ : Entity_Id;
623
624 Desig_Typ : Entity_Id;
625 -- This is either a copy of T, or if T is an access type, then it is
626 -- the directly designated type of this access type.
627
628 function Build_Actual_Array_Constraint return List_Id;
629 -- If one or more of the bounds of the component depends on
630 -- discriminants, build actual constraint using the discriminants
631 -- of the prefix.
632
633 function Build_Actual_Record_Constraint return List_Id;
634 -- Similar to previous one, for discriminated components constrained
635 -- by the discriminant of the enclosing object.
636
637 -----------------------------------
638 -- Build_Actual_Array_Constraint --
639 -----------------------------------
640
641 function Build_Actual_Array_Constraint return List_Id is
642 Constraints : constant List_Id := New_List;
643 Indx : Node_Id;
644 Hi : Node_Id;
645 Lo : Node_Id;
646 Old_Hi : Node_Id;
647 Old_Lo : Node_Id;
648
649 begin
650 Indx := First_Index (Desig_Typ);
651 while Present (Indx) loop
652 Old_Lo := Type_Low_Bound (Etype (Indx));
653 Old_Hi := Type_High_Bound (Etype (Indx));
654
655 if Denotes_Discriminant (Old_Lo) then
656 Lo :=
657 Make_Selected_Component (Loc,
658 Prefix => New_Copy_Tree (P),
659 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
660
661 else
662 Lo := New_Copy_Tree (Old_Lo);
663
664 -- The new bound will be reanalyzed in the enclosing
665 -- declaration. For literal bounds that come from a type
666 -- declaration, the type of the context must be imposed, so
667 -- insure that analysis will take place. For non-universal
668 -- types this is not strictly necessary.
669
670 Set_Analyzed (Lo, False);
671 end if;
672
673 if Denotes_Discriminant (Old_Hi) then
674 Hi :=
675 Make_Selected_Component (Loc,
676 Prefix => New_Copy_Tree (P),
677 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
678
679 else
680 Hi := New_Copy_Tree (Old_Hi);
681 Set_Analyzed (Hi, False);
682 end if;
683
684 Append (Make_Range (Loc, Lo, Hi), Constraints);
685 Next_Index (Indx);
686 end loop;
687
688 return Constraints;
689 end Build_Actual_Array_Constraint;
690
691 ------------------------------------
692 -- Build_Actual_Record_Constraint --
693 ------------------------------------
694
695 function Build_Actual_Record_Constraint return List_Id is
696 Constraints : constant List_Id := New_List;
697 D : Elmt_Id;
698 D_Val : Node_Id;
699
700 begin
701 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
702 while Present (D) loop
703 if Denotes_Discriminant (Node (D)) then
704 D_Val := Make_Selected_Component (Loc,
705 Prefix => New_Copy_Tree (P),
706 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
707
708 else
709 D_Val := New_Copy_Tree (Node (D));
710 end if;
711
712 Append (D_Val, Constraints);
713 Next_Elmt (D);
714 end loop;
715
716 return Constraints;
717 end Build_Actual_Record_Constraint;
718
719 -- Start of processing for Build_Actual_Subtype_Of_Component
720
721 begin
722 -- Why the test for Spec_Expression mode here???
723
724 if In_Spec_Expression then
725 return Empty;
726
727 -- More comments for the rest of this body would be good ???
728
729 elsif Nkind (N) = N_Explicit_Dereference then
730 if Is_Composite_Type (T)
731 and then not Is_Constrained (T)
732 and then not (Is_Class_Wide_Type (T)
733 and then Is_Constrained (Root_Type (T)))
734 and then not Has_Unknown_Discriminants (T)
735 then
736 -- If the type of the dereference is already constrained, it is an
737 -- actual subtype.
738
739 if Is_Array_Type (Etype (N))
740 and then Is_Constrained (Etype (N))
741 then
742 return Empty;
743 else
744 Remove_Side_Effects (P);
745 return Build_Actual_Subtype (T, N);
746 end if;
747 else
748 return Empty;
749 end if;
750 end if;
751
752 if Ekind (T) = E_Access_Subtype then
753 Desig_Typ := Designated_Type (T);
754 else
755 Desig_Typ := T;
756 end if;
757
758 if Ekind (Desig_Typ) = E_Array_Subtype then
759 Id := First_Index (Desig_Typ);
760 while Present (Id) loop
761 Index_Typ := Underlying_Type (Etype (Id));
762
763 if Denotes_Discriminant (Type_Low_Bound (Index_Typ))
764 or else
765 Denotes_Discriminant (Type_High_Bound (Index_Typ))
766 then
767 Remove_Side_Effects (P);
768 return
769 Build_Component_Subtype
770 (Build_Actual_Array_Constraint, Loc, Base_Type (T));
771 end if;
772
773 Next_Index (Id);
774 end loop;
775
776 elsif Is_Composite_Type (Desig_Typ)
777 and then Has_Discriminants (Desig_Typ)
778 and then not Has_Unknown_Discriminants (Desig_Typ)
779 then
780 if Is_Private_Type (Desig_Typ)
781 and then No (Discriminant_Constraint (Desig_Typ))
782 then
783 Desig_Typ := Full_View (Desig_Typ);
784 end if;
785
786 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
787 while Present (D) loop
788 if Denotes_Discriminant (Node (D)) then
789 Remove_Side_Effects (P);
790 return
791 Build_Component_Subtype (
792 Build_Actual_Record_Constraint, Loc, Base_Type (T));
793 end if;
794
795 Next_Elmt (D);
796 end loop;
797 end if;
798
799 -- If none of the above, the actual and nominal subtypes are the same
800
801 return Empty;
802 end Build_Actual_Subtype_Of_Component;
803
804 -----------------------------
805 -- Build_Component_Subtype --
806 -----------------------------
807
808 function Build_Component_Subtype
809 (C : List_Id;
810 Loc : Source_Ptr;
811 T : Entity_Id) return Node_Id
812 is
813 Subt : Entity_Id;
814 Decl : Node_Id;
815
816 begin
817 -- Unchecked_Union components do not require component subtypes
818
819 if Is_Unchecked_Union (T) then
820 return Empty;
821 end if;
822
823 Subt := Make_Temporary (Loc, 'S');
824 Set_Is_Internal (Subt);
825
826 Decl :=
827 Make_Subtype_Declaration (Loc,
828 Defining_Identifier => Subt,
829 Subtype_Indication =>
830 Make_Subtype_Indication (Loc,
831 Subtype_Mark => New_Reference_To (Base_Type (T), Loc),
832 Constraint =>
833 Make_Index_Or_Discriminant_Constraint (Loc,
834 Constraints => C)));
835
836 Mark_Rewrite_Insertion (Decl);
837 return Decl;
838 end Build_Component_Subtype;
839
840 ---------------------------
841 -- Build_Default_Subtype --
842 ---------------------------
843
844 function Build_Default_Subtype
845 (T : Entity_Id;
846 N : Node_Id) return Entity_Id
847 is
848 Loc : constant Source_Ptr := Sloc (N);
849 Disc : Entity_Id;
850
851 Bas : Entity_Id;
852 -- The base type that is to be constrained by the defaults
853
854 begin
855 if not Has_Discriminants (T) or else Is_Constrained (T) then
856 return T;
857 end if;
858
859 Bas := Base_Type (T);
860
861 -- If T is non-private but its base type is private, this is the
862 -- completion of a subtype declaration whose parent type is private
863 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
864 -- are to be found in the full view of the base.
865
866 if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then
867 Bas := Full_View (Bas);
868 end if;
869
870 Disc := First_Discriminant (T);
871
872 if No (Discriminant_Default_Value (Disc)) then
873 return T;
874 end if;
875
876 declare
877 Act : constant Entity_Id := Make_Temporary (Loc, 'S');
878 Constraints : constant List_Id := New_List;
879 Decl : Node_Id;
880
881 begin
882 while Present (Disc) loop
883 Append_To (Constraints,
884 New_Copy_Tree (Discriminant_Default_Value (Disc)));
885 Next_Discriminant (Disc);
886 end loop;
887
888 Decl :=
889 Make_Subtype_Declaration (Loc,
890 Defining_Identifier => Act,
891 Subtype_Indication =>
892 Make_Subtype_Indication (Loc,
893 Subtype_Mark => New_Occurrence_Of (Bas, Loc),
894 Constraint =>
895 Make_Index_Or_Discriminant_Constraint (Loc,
896 Constraints => Constraints)));
897
898 Insert_Action (N, Decl);
899 Analyze (Decl);
900 return Act;
901 end;
902 end Build_Default_Subtype;
903
904 --------------------------------------------
905 -- Build_Discriminal_Subtype_Of_Component --
906 --------------------------------------------
907
908 function Build_Discriminal_Subtype_Of_Component
909 (T : Entity_Id) return Node_Id
910 is
911 Loc : constant Source_Ptr := Sloc (T);
912 D : Elmt_Id;
913 Id : Node_Id;
914
915 function Build_Discriminal_Array_Constraint return List_Id;
916 -- If one or more of the bounds of the component depends on
917 -- discriminants, build actual constraint using the discriminants
918 -- of the prefix.
919
920 function Build_Discriminal_Record_Constraint return List_Id;
921 -- Similar to previous one, for discriminated components constrained by
922 -- the discriminant of the enclosing object.
923
924 ----------------------------------------
925 -- Build_Discriminal_Array_Constraint --
926 ----------------------------------------
927
928 function Build_Discriminal_Array_Constraint return List_Id is
929 Constraints : constant List_Id := New_List;
930 Indx : Node_Id;
931 Hi : Node_Id;
932 Lo : Node_Id;
933 Old_Hi : Node_Id;
934 Old_Lo : Node_Id;
935
936 begin
937 Indx := First_Index (T);
938 while Present (Indx) loop
939 Old_Lo := Type_Low_Bound (Etype (Indx));
940 Old_Hi := Type_High_Bound (Etype (Indx));
941
942 if Denotes_Discriminant (Old_Lo) then
943 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
944
945 else
946 Lo := New_Copy_Tree (Old_Lo);
947 end if;
948
949 if Denotes_Discriminant (Old_Hi) then
950 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
951
952 else
953 Hi := New_Copy_Tree (Old_Hi);
954 end if;
955
956 Append (Make_Range (Loc, Lo, Hi), Constraints);
957 Next_Index (Indx);
958 end loop;
959
960 return Constraints;
961 end Build_Discriminal_Array_Constraint;
962
963 -----------------------------------------
964 -- Build_Discriminal_Record_Constraint --
965 -----------------------------------------
966
967 function Build_Discriminal_Record_Constraint return List_Id is
968 Constraints : constant List_Id := New_List;
969 D : Elmt_Id;
970 D_Val : Node_Id;
971
972 begin
973 D := First_Elmt (Discriminant_Constraint (T));
974 while Present (D) loop
975 if Denotes_Discriminant (Node (D)) then
976 D_Val :=
977 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
978
979 else
980 D_Val := New_Copy_Tree (Node (D));
981 end if;
982
983 Append (D_Val, Constraints);
984 Next_Elmt (D);
985 end loop;
986
987 return Constraints;
988 end Build_Discriminal_Record_Constraint;
989
990 -- Start of processing for Build_Discriminal_Subtype_Of_Component
991
992 begin
993 if Ekind (T) = E_Array_Subtype then
994 Id := First_Index (T);
995 while Present (Id) loop
996 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else
997 Denotes_Discriminant (Type_High_Bound (Etype (Id)))
998 then
999 return Build_Component_Subtype
1000 (Build_Discriminal_Array_Constraint, Loc, T);
1001 end if;
1002
1003 Next_Index (Id);
1004 end loop;
1005
1006 elsif Ekind (T) = E_Record_Subtype
1007 and then Has_Discriminants (T)
1008 and then not Has_Unknown_Discriminants (T)
1009 then
1010 D := First_Elmt (Discriminant_Constraint (T));
1011 while Present (D) loop
1012 if Denotes_Discriminant (Node (D)) then
1013 return Build_Component_Subtype
1014 (Build_Discriminal_Record_Constraint, Loc, T);
1015 end if;
1016
1017 Next_Elmt (D);
1018 end loop;
1019 end if;
1020
1021 -- If none of the above, the actual and nominal subtypes are the same
1022
1023 return Empty;
1024 end Build_Discriminal_Subtype_Of_Component;
1025
1026 ------------------------------
1027 -- Build_Elaboration_Entity --
1028 ------------------------------
1029
1030 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
1031 Loc : constant Source_Ptr := Sloc (N);
1032 Decl : Node_Id;
1033 Elab_Ent : Entity_Id;
1034
1035 procedure Set_Package_Name (Ent : Entity_Id);
1036 -- Given an entity, sets the fully qualified name of the entity in
1037 -- Name_Buffer, with components separated by double underscores. This
1038 -- is a recursive routine that climbs the scope chain to Standard.
1039
1040 ----------------------
1041 -- Set_Package_Name --
1042 ----------------------
1043
1044 procedure Set_Package_Name (Ent : Entity_Id) is
1045 begin
1046 if Scope (Ent) /= Standard_Standard then
1047 Set_Package_Name (Scope (Ent));
1048
1049 declare
1050 Nam : constant String := Get_Name_String (Chars (Ent));
1051 begin
1052 Name_Buffer (Name_Len + 1) := '_';
1053 Name_Buffer (Name_Len + 2) := '_';
1054 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
1055 Name_Len := Name_Len + Nam'Length + 2;
1056 end;
1057
1058 else
1059 Get_Name_String (Chars (Ent));
1060 end if;
1061 end Set_Package_Name;
1062
1063 -- Start of processing for Build_Elaboration_Entity
1064
1065 begin
1066 -- Ignore if already constructed
1067
1068 if Present (Elaboration_Entity (Spec_Id)) then
1069 return;
1070 end if;
1071
1072 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
1073 -- name with dots replaced by double underscore. We have to manually
1074 -- construct this name, since it will be elaborated in the outer scope,
1075 -- and thus will not have the unit name automatically prepended.
1076
1077 Set_Package_Name (Spec_Id);
1078 Add_Str_To_Name_Buffer ("_E");
1079
1080 -- Create elaboration counter
1081
1082 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
1083 Set_Elaboration_Entity (Spec_Id, Elab_Ent);
1084
1085 Decl :=
1086 Make_Object_Declaration (Loc,
1087 Defining_Identifier => Elab_Ent,
1088 Object_Definition =>
1089 New_Occurrence_Of (Standard_Short_Integer, Loc),
1090 Expression => Make_Integer_Literal (Loc, Uint_0));
1091
1092 Push_Scope (Standard_Standard);
1093 Add_Global_Declaration (Decl);
1094 Pop_Scope;
1095
1096 -- Reset True_Constant indication, since we will indeed assign a value
1097 -- to the variable in the binder main. We also kill the Current_Value
1098 -- and Last_Assignment fields for the same reason.
1099
1100 Set_Is_True_Constant (Elab_Ent, False);
1101 Set_Current_Value (Elab_Ent, Empty);
1102 Set_Last_Assignment (Elab_Ent, Empty);
1103
1104 -- We do not want any further qualification of the name (if we did not
1105 -- do this, we would pick up the name of the generic package in the case
1106 -- of a library level generic instantiation).
1107
1108 Set_Has_Qualified_Name (Elab_Ent);
1109 Set_Has_Fully_Qualified_Name (Elab_Ent);
1110 end Build_Elaboration_Entity;
1111
1112 --------------------------------
1113 -- Build_Explicit_Dereference --
1114 --------------------------------
1115
1116 procedure Build_Explicit_Dereference
1117 (Expr : Node_Id;
1118 Disc : Entity_Id)
1119 is
1120 Loc : constant Source_Ptr := Sloc (Expr);
1121 begin
1122
1123 -- An entity of a type with a reference aspect is overloaded with
1124 -- both interpretations: with and without the dereference. Now that
1125 -- the dereference is made explicit, set the type of the node properly,
1126 -- to prevent anomalies in the backend. Same if the expression is an
1127 -- overloaded function call whose return type has a reference aspect.
1128
1129 if Is_Entity_Name (Expr) then
1130 Set_Etype (Expr, Etype (Entity (Expr)));
1131
1132 elsif Nkind (Expr) = N_Function_Call then
1133 Set_Etype (Expr, Etype (Name (Expr)));
1134 end if;
1135
1136 Set_Is_Overloaded (Expr, False);
1137 Rewrite (Expr,
1138 Make_Explicit_Dereference (Loc,
1139 Prefix =>
1140 Make_Selected_Component (Loc,
1141 Prefix => Relocate_Node (Expr),
1142 Selector_Name => New_Occurrence_Of (Disc, Loc))));
1143 Set_Etype (Prefix (Expr), Etype (Disc));
1144 Set_Etype (Expr, Designated_Type (Etype (Disc)));
1145 end Build_Explicit_Dereference;
1146
1147 -----------------------------------
1148 -- Cannot_Raise_Constraint_Error --
1149 -----------------------------------
1150
1151 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
1152 begin
1153 if Compile_Time_Known_Value (Expr) then
1154 return True;
1155
1156 elsif Do_Range_Check (Expr) then
1157 return False;
1158
1159 elsif Raises_Constraint_Error (Expr) then
1160 return False;
1161
1162 else
1163 case Nkind (Expr) is
1164 when N_Identifier =>
1165 return True;
1166
1167 when N_Expanded_Name =>
1168 return True;
1169
1170 when N_Selected_Component =>
1171 return not Do_Discriminant_Check (Expr);
1172
1173 when N_Attribute_Reference =>
1174 if Do_Overflow_Check (Expr) then
1175 return False;
1176
1177 elsif No (Expressions (Expr)) then
1178 return True;
1179
1180 else
1181 declare
1182 N : Node_Id;
1183
1184 begin
1185 N := First (Expressions (Expr));
1186 while Present (N) loop
1187 if Cannot_Raise_Constraint_Error (N) then
1188 Next (N);
1189 else
1190 return False;
1191 end if;
1192 end loop;
1193
1194 return True;
1195 end;
1196 end if;
1197
1198 when N_Type_Conversion =>
1199 if Do_Overflow_Check (Expr)
1200 or else Do_Length_Check (Expr)
1201 or else Do_Tag_Check (Expr)
1202 then
1203 return False;
1204 else
1205 return Cannot_Raise_Constraint_Error (Expression (Expr));
1206 end if;
1207
1208 when N_Unchecked_Type_Conversion =>
1209 return Cannot_Raise_Constraint_Error (Expression (Expr));
1210
1211 when N_Unary_Op =>
1212 if Do_Overflow_Check (Expr) then
1213 return False;
1214 else
1215 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1216 end if;
1217
1218 when N_Op_Divide |
1219 N_Op_Mod |
1220 N_Op_Rem
1221 =>
1222 if Do_Division_Check (Expr)
1223 or else Do_Overflow_Check (Expr)
1224 then
1225 return False;
1226 else
1227 return
1228 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1229 and then
1230 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1231 end if;
1232
1233 when N_Op_Add |
1234 N_Op_And |
1235 N_Op_Concat |
1236 N_Op_Eq |
1237 N_Op_Expon |
1238 N_Op_Ge |
1239 N_Op_Gt |
1240 N_Op_Le |
1241 N_Op_Lt |
1242 N_Op_Multiply |
1243 N_Op_Ne |
1244 N_Op_Or |
1245 N_Op_Rotate_Left |
1246 N_Op_Rotate_Right |
1247 N_Op_Shift_Left |
1248 N_Op_Shift_Right |
1249 N_Op_Shift_Right_Arithmetic |
1250 N_Op_Subtract |
1251 N_Op_Xor
1252 =>
1253 if Do_Overflow_Check (Expr) then
1254 return False;
1255 else
1256 return
1257 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1258 and then
1259 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1260 end if;
1261
1262 when others =>
1263 return False;
1264 end case;
1265 end if;
1266 end Cannot_Raise_Constraint_Error;
1267
1268 -----------------------------------------
1269 -- Check_Dynamically_Tagged_Expression --
1270 -----------------------------------------
1271
1272 procedure Check_Dynamically_Tagged_Expression
1273 (Expr : Node_Id;
1274 Typ : Entity_Id;
1275 Related_Nod : Node_Id)
1276 is
1277 begin
1278 pragma Assert (Is_Tagged_Type (Typ));
1279
1280 -- In order to avoid spurious errors when analyzing the expanded code,
1281 -- this check is done only for nodes that come from source and for
1282 -- actuals of generic instantiations.
1283
1284 if (Comes_From_Source (Related_Nod)
1285 or else In_Generic_Actual (Expr))
1286 and then (Is_Class_Wide_Type (Etype (Expr))
1287 or else Is_Dynamically_Tagged (Expr))
1288 and then Is_Tagged_Type (Typ)
1289 and then not Is_Class_Wide_Type (Typ)
1290 then
1291 Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
1292 end if;
1293 end Check_Dynamically_Tagged_Expression;
1294
1295 -----------------------------------------------
1296 -- Check_Expression_Against_Static_Predicate --
1297 -----------------------------------------------
1298
1299 procedure Check_Expression_Against_Static_Predicate
1300 (Expr : Node_Id;
1301 Typ : Entity_Id)
1302 is
1303 begin
1304 -- When the predicate is static and the value of the expression is known
1305 -- at compile time, evaluate the predicate check. A type is non-static
1306 -- when it has aspect Dynamic_Predicate.
1307
1308 if Compile_Time_Known_Value (Expr)
1309 and then Has_Predicates (Typ)
1310 and then Present (Static_Predicate (Typ))
1311 and then not Has_Dynamic_Predicate_Aspect (Typ)
1312 then
1313 -- Either -gnatc is enabled or the expression is ok
1314
1315 if Operating_Mode < Generate_Code
1316 or else Eval_Static_Predicate_Check (Expr, Typ)
1317 then
1318 null;
1319
1320 -- The expression is prohibited by the static predicate
1321
1322 else
1323 Error_Msg_NE
1324 ("?static expression fails static predicate check on &",
1325 Expr, Typ);
1326 end if;
1327 end if;
1328 end Check_Expression_Against_Static_Predicate;
1329
1330 --------------------------
1331 -- Check_Fully_Declared --
1332 --------------------------
1333
1334 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
1335 begin
1336 if Ekind (T) = E_Incomplete_Type then
1337
1338 -- Ada 2005 (AI-50217): If the type is available through a limited
1339 -- with_clause, verify that its full view has been analyzed.
1340
1341 if From_With_Type (T)
1342 and then Present (Non_Limited_View (T))
1343 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
1344 then
1345 -- The non-limited view is fully declared
1346 null;
1347
1348 else
1349 Error_Msg_NE
1350 ("premature usage of incomplete}", N, First_Subtype (T));
1351 end if;
1352
1353 -- Need comments for these tests ???
1354
1355 elsif Has_Private_Component (T)
1356 and then not Is_Generic_Type (Root_Type (T))
1357 and then not In_Spec_Expression
1358 then
1359 -- Special case: if T is the anonymous type created for a single
1360 -- task or protected object, use the name of the source object.
1361
1362 if Is_Concurrent_Type (T)
1363 and then not Comes_From_Source (T)
1364 and then Nkind (N) = N_Object_Declaration
1365 then
1366 Error_Msg_NE ("type of& has incomplete component", N,
1367 Defining_Identifier (N));
1368
1369 else
1370 Error_Msg_NE
1371 ("premature usage of incomplete}", N, First_Subtype (T));
1372 end if;
1373 end if;
1374 end Check_Fully_Declared;
1375
1376 -------------------------------------
1377 -- Check_Function_Writable_Actuals --
1378 -------------------------------------
1379
1380 procedure Check_Function_Writable_Actuals (N : Node_Id) is
1381 Writable_Actuals_List : Elist_Id := No_Elist;
1382 Identifiers_List : Elist_Id := No_Elist;
1383 Error_Node : Node_Id := Empty;
1384
1385 procedure Collect_Identifiers (N : Node_Id);
1386 -- In a single traversal of subtree N collect in Writable_Actuals_List
1387 -- all the actuals of functions with writable actuals, and in the list
1388 -- Identifiers_List collect all the identifiers that are not actuals of
1389 -- functions with writable actuals. If a writable actual is referenced
1390 -- twice as writable actual then Error_Node is set to reference its
1391 -- second occurrence, the error is reported, and the tree traversal
1392 -- is abandoned.
1393
1394 function Get_Function_Id (Call : Node_Id) return Entity_Id;
1395 -- Return the entity associated with the function call
1396
1397 procedure Preanalyze_Without_Errors (N : Node_Id);
1398 -- Preanalyze N without reporting errors. Very dubious, you can't just
1399 -- go analyzing things more than once???
1400
1401 -------------------------
1402 -- Collect_Identifiers --
1403 -------------------------
1404
1405 procedure Collect_Identifiers (N : Node_Id) is
1406
1407 function Check_Node (N : Node_Id) return Traverse_Result;
1408 -- Process a single node during the tree traversal to collect the
1409 -- writable actuals of functions and all the identifiers which are
1410 -- not writable actuals of functions.
1411
1412 function Contains (List : Elist_Id; N : Node_Id) return Boolean;
1413 -- Returns True if List has a node whose Entity is Entity (N)
1414
1415 -------------------------
1416 -- Check_Function_Call --
1417 -------------------------
1418
1419 function Check_Node (N : Node_Id) return Traverse_Result is
1420 Is_Writable_Actual : Boolean := False;
1421
1422 begin
1423 if Nkind (N) = N_Identifier then
1424
1425 -- No analysis possible if the entity is not decorated
1426
1427 if No (Entity (N)) then
1428 return Skip;
1429
1430 -- Don't collect identifiers of packages, called functions, etc
1431
1432 elsif Ekind_In (Entity (N), E_Package,
1433 E_Function,
1434 E_Procedure,
1435 E_Entry)
1436 then
1437 return Skip;
1438
1439 -- Analyze if N is a writable actual of a function
1440
1441 elsif Nkind (Parent (N)) = N_Function_Call then
1442 declare
1443 Call : constant Node_Id := Parent (N);
1444 Id : constant Entity_Id := Get_Function_Id (Call);
1445 Actual : Node_Id;
1446 Formal : Node_Id;
1447
1448 begin
1449 Formal := First_Formal (Id);
1450 Actual := First_Actual (Call);
1451 while Present (Actual) and then Present (Formal) loop
1452 if Actual = N then
1453 if Ekind_In (Formal, E_Out_Parameter,
1454 E_In_Out_Parameter)
1455 then
1456 Is_Writable_Actual := True;
1457 end if;
1458
1459 exit;
1460 end if;
1461
1462 Next_Formal (Formal);
1463 Next_Actual (Actual);
1464 end loop;
1465 end;
1466 end if;
1467
1468 if Is_Writable_Actual then
1469 if Contains (Writable_Actuals_List, N) then
1470 Error_Msg_N
1471 ("conflict of writable function parameter in "
1472 & "construct with arbitrary order of evaluation", N);
1473 Error_Node := N;
1474 return Abandon;
1475 end if;
1476
1477 if Writable_Actuals_List = No_Elist then
1478 Writable_Actuals_List := New_Elmt_List;
1479 end if;
1480
1481 Append_Elmt (N, Writable_Actuals_List);
1482 else
1483 if Identifiers_List = No_Elist then
1484 Identifiers_List := New_Elmt_List;
1485 end if;
1486
1487 Append_Unique_Elmt (N, Identifiers_List);
1488 end if;
1489 end if;
1490
1491 return OK;
1492 end Check_Node;
1493
1494 --------------
1495 -- Contains --
1496 --------------
1497
1498 function Contains
1499 (List : Elist_Id;
1500 N : Node_Id) return Boolean
1501 is
1502 pragma Assert (Nkind (N) in N_Has_Entity);
1503
1504 Elmt : Elmt_Id;
1505
1506 begin
1507 if List = No_Elist then
1508 return False;
1509 end if;
1510
1511 Elmt := First_Elmt (List);
1512 while Present (Elmt) loop
1513 if Entity (Node (Elmt)) = Entity (N) then
1514 return True;
1515 else
1516 Next_Elmt (Elmt);
1517 end if;
1518 end loop;
1519
1520 return False;
1521 end Contains;
1522
1523 ------------------
1524 -- Do_Traversal --
1525 ------------------
1526
1527 procedure Do_Traversal is new Traverse_Proc (Check_Node);
1528 -- The traversal procedure
1529
1530 -- Start of processing for Collect_Identifiers
1531
1532 begin
1533 if Present (Error_Node) then
1534 return;
1535 end if;
1536
1537 if Nkind (N) in N_Subexpr
1538 and then Is_Static_Expression (N)
1539 then
1540 return;
1541 end if;
1542
1543 Do_Traversal (N);
1544 end Collect_Identifiers;
1545
1546 ---------------------
1547 -- Get_Function_Id --
1548 ---------------------
1549
1550 function Get_Function_Id (Call : Node_Id) return Entity_Id is
1551 Nam : constant Node_Id := Name (Call);
1552 Id : Entity_Id;
1553
1554 begin
1555 if Nkind (Nam) = N_Explicit_Dereference then
1556 Id := Etype (Nam);
1557 pragma Assert (Ekind (Id) = E_Subprogram_Type);
1558
1559 elsif Nkind (Nam) = N_Selected_Component then
1560 Id := Entity (Selector_Name (Nam));
1561
1562 elsif Nkind (Nam) = N_Indexed_Component then
1563 Id := Entity (Selector_Name (Prefix (Nam)));
1564
1565 else
1566 Id := Entity (Nam);
1567 end if;
1568
1569 return Id;
1570 end Get_Function_Id;
1571
1572 ---------------------------
1573 -- Preanalyze_Expression --
1574 ---------------------------
1575
1576 procedure Preanalyze_Without_Errors (N : Node_Id) is
1577 Status : constant Boolean := Get_Ignore_Errors;
1578 begin
1579 Set_Ignore_Errors (True);
1580 Preanalyze (N);
1581 Set_Ignore_Errors (Status);
1582 end Preanalyze_Without_Errors;
1583
1584 -- Start of processing for Check_Function_Writable_Actuals
1585
1586 begin
1587 if Ada_Version < Ada_2012
1588 or else (not (Nkind (N) in N_Op)
1589 and then not (Nkind (N) in N_Membership_Test)
1590 and then not Nkind_In (N, N_Range,
1591 N_Aggregate,
1592 N_Extension_Aggregate,
1593 N_Full_Type_Declaration,
1594 N_Function_Call,
1595 N_Procedure_Call_Statement,
1596 N_Entry_Call_Statement))
1597 or else (Nkind (N) = N_Full_Type_Declaration
1598 and then not Is_Record_Type (Defining_Identifier (N)))
1599 then
1600 return;
1601 end if;
1602
1603 -- If a construct C has two or more direct constituents that are names
1604 -- or expressions whose evaluation may occur in an arbitrary order, at
1605 -- least one of which contains a function call with an in out or out
1606 -- parameter, then the construct is legal only if: for each name N that
1607 -- is passed as a parameter of mode in out or out to some inner function
1608 -- call C2 (not including the construct C itself), there is no other
1609 -- name anywhere within a direct constituent of the construct C other
1610 -- than the one containing C2, that is known to refer to the same
1611 -- object (RM 6.4.1(6.17/3)).
1612
1613 case Nkind (N) is
1614 when N_Range =>
1615 Collect_Identifiers (Low_Bound (N));
1616 Collect_Identifiers (High_Bound (N));
1617
1618 when N_Op | N_Membership_Test =>
1619 declare
1620 Expr : Node_Id;
1621 begin
1622 Collect_Identifiers (Left_Opnd (N));
1623
1624 if Present (Right_Opnd (N)) then
1625 Collect_Identifiers (Right_Opnd (N));
1626 end if;
1627
1628 if Nkind_In (N, N_In, N_Not_In)
1629 and then Present (Alternatives (N))
1630 then
1631 Expr := First (Alternatives (N));
1632 while Present (Expr) loop
1633 Collect_Identifiers (Expr);
1634
1635 Next (Expr);
1636 end loop;
1637 end if;
1638 end;
1639
1640 when N_Full_Type_Declaration =>
1641 declare
1642 function Get_Record_Part (N : Node_Id) return Node_Id;
1643 -- Return the record part of this record type definition
1644
1645 function Get_Record_Part (N : Node_Id) return Node_Id is
1646 Type_Def : constant Node_Id := Type_Definition (N);
1647 begin
1648 if Nkind (Type_Def) = N_Derived_Type_Definition then
1649 return Record_Extension_Part (Type_Def);
1650 else
1651 return Type_Def;
1652 end if;
1653 end Get_Record_Part;
1654
1655 Comp : Node_Id;
1656 Def_Id : Entity_Id := Defining_Identifier (N);
1657 Rec : Node_Id := Get_Record_Part (N);
1658
1659 begin
1660 -- No need to perform any analysis if the record has no
1661 -- components
1662
1663 if No (Rec) or else No (Component_List (Rec)) then
1664 return;
1665 end if;
1666
1667 -- Collect the identifiers starting from the deepest
1668 -- derivation. Done to report the error in the deepest
1669 -- derivation.
1670
1671 loop
1672 if Present (Component_List (Rec)) then
1673 Comp := First (Component_Items (Component_List (Rec)));
1674 while Present (Comp) loop
1675 if Nkind (Comp) = N_Component_Declaration
1676 and then Present (Expression (Comp))
1677 then
1678 Collect_Identifiers (Expression (Comp));
1679 end if;
1680
1681 Next (Comp);
1682 end loop;
1683 end if;
1684
1685 exit when No (Underlying_Type (Etype (Def_Id)))
1686 or else Base_Type (Underlying_Type (Etype (Def_Id)))
1687 = Def_Id;
1688
1689 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
1690 Rec := Get_Record_Part (Parent (Def_Id));
1691 end loop;
1692 end;
1693
1694 when N_Subprogram_Call |
1695 N_Entry_Call_Statement =>
1696 declare
1697 Id : constant Entity_Id := Get_Function_Id (N);
1698 Formal : Node_Id;
1699 Actual : Node_Id;
1700
1701 begin
1702 Formal := First_Formal (Id);
1703 Actual := First_Actual (N);
1704 while Present (Actual) and then Present (Formal) loop
1705 if Ekind_In (Formal, E_Out_Parameter,
1706 E_In_Out_Parameter)
1707 then
1708 Collect_Identifiers (Actual);
1709 end if;
1710
1711 Next_Formal (Formal);
1712 Next_Actual (Actual);
1713 end loop;
1714 end;
1715
1716 when N_Aggregate |
1717 N_Extension_Aggregate =>
1718 declare
1719 Assoc : Node_Id;
1720 Choice : Node_Id;
1721 Comp_Expr : Node_Id;
1722
1723 begin
1724 -- Handle the N_Others_Choice of array aggregates with static
1725 -- bounds. There is no need to perform this analysis in
1726 -- aggregates without static bounds since we cannot evaluate
1727 -- if the N_Others_Choice covers several elements. There is
1728 -- no need to handle the N_Others choice of record aggregates
1729 -- since at this stage it has been already expanded by
1730 -- Resolve_Record_Aggregate.
1731
1732 if Is_Array_Type (Etype (N))
1733 and then Nkind (N) = N_Aggregate
1734 and then Present (Aggregate_Bounds (N))
1735 and then Compile_Time_Known_Bounds (Etype (N))
1736 and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
1737 > Expr_Value (Low_Bound (Aggregate_Bounds (N)))
1738 then
1739 declare
1740 Count_Components : Uint := Uint_0;
1741 Num_Components : Uint;
1742 Others_Assoc : Node_Id;
1743 Others_Choice : Node_Id := Empty;
1744 Others_Box_Present : Boolean := False;
1745
1746 begin
1747 -- Count positional associations
1748
1749 if Present (Expressions (N)) then
1750 Comp_Expr := First (Expressions (N));
1751 while Present (Comp_Expr) loop
1752 Count_Components := Count_Components + 1;
1753 Next (Comp_Expr);
1754 end loop;
1755 end if;
1756
1757 -- Count the rest of elements and locate the N_Others
1758 -- choice (if any)
1759
1760 Assoc := First (Component_Associations (N));
1761 while Present (Assoc) loop
1762 Choice := First (Choices (Assoc));
1763 while Present (Choice) loop
1764 if Nkind (Choice) = N_Others_Choice then
1765 Others_Assoc := Assoc;
1766 Others_Choice := Choice;
1767 Others_Box_Present := Box_Present (Assoc);
1768
1769 -- Count several components
1770
1771 elsif Nkind_In (Choice, N_Range,
1772 N_Subtype_Indication)
1773 or else (Is_Entity_Name (Choice)
1774 and then Is_Type (Entity (Choice)))
1775 then
1776 declare
1777 L, H : Node_Id;
1778 begin
1779 Get_Index_Bounds (Choice, L, H);
1780 pragma Assert
1781 (Compile_Time_Known_Value (L)
1782 and then Compile_Time_Known_Value (H));
1783 Count_Components :=
1784 Count_Components
1785 + Expr_Value (H) - Expr_Value (L) + 1;
1786 end;
1787
1788 -- Count single component. No other case available
1789 -- since we are handling an aggregate with static
1790 -- bounds.
1791
1792 else
1793 pragma Assert (Is_Static_Expression (Choice)
1794 or else Nkind (Choice) = N_Identifier
1795 or else Nkind (Choice) = N_Integer_Literal);
1796
1797 Count_Components := Count_Components + 1;
1798 end if;
1799
1800 Next (Choice);
1801 end loop;
1802
1803 Next (Assoc);
1804 end loop;
1805
1806 Num_Components :=
1807 Expr_Value (High_Bound (Aggregate_Bounds (N))) -
1808 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
1809
1810 pragma Assert (Count_Components <= Num_Components);
1811
1812 -- Handle the N_Others choice if it covers several
1813 -- components
1814
1815 if Present (Others_Choice)
1816 and then (Num_Components - Count_Components) > 1
1817 then
1818 if not Others_Box_Present then
1819
1820 -- At this stage, if expansion is active, the
1821 -- expression of the others choice has not been
1822 -- analyzed. Hence we generate a duplicate and
1823 -- we analyze it silently to have available the
1824 -- minimum decoration required to collect the
1825 -- identifiers.
1826
1827 if not Expander_Active then
1828 Comp_Expr := Expression (Others_Assoc);
1829 else
1830 Comp_Expr :=
1831 New_Copy_Tree (Expression (Others_Assoc));
1832 Preanalyze_Without_Errors (Comp_Expr);
1833 end if;
1834
1835 Collect_Identifiers (Comp_Expr);
1836
1837 if Writable_Actuals_List /= No_Elist then
1838
1839 -- As suggested by Robert, at current stage we
1840 -- report occurrences of this case as warnings.
1841
1842 Error_Msg_N
1843 ("conflict of writable function parameter in "
1844 & "construct with arbitrary order of "
1845 & "evaluation?",
1846 Node (First_Elmt (Writable_Actuals_List)));
1847 end if;
1848 end if;
1849 end if;
1850 end;
1851 end if;
1852
1853 -- Handle ancestor part of extension aggregates
1854
1855 if Nkind (N) = N_Extension_Aggregate then
1856 Collect_Identifiers (Ancestor_Part (N));
1857 end if;
1858
1859 -- Handle positional associations
1860
1861 if Present (Expressions (N)) then
1862 Comp_Expr := First (Expressions (N));
1863 while Present (Comp_Expr) loop
1864 if not Is_Static_Expression (Comp_Expr) then
1865 Collect_Identifiers (Comp_Expr);
1866 end if;
1867
1868 Next (Comp_Expr);
1869 end loop;
1870 end if;
1871
1872 -- Handle discrete associations
1873
1874 if Present (Component_Associations (N)) then
1875 Assoc := First (Component_Associations (N));
1876 while Present (Assoc) loop
1877
1878 if not Box_Present (Assoc) then
1879 Choice := First (Choices (Assoc));
1880 while Present (Choice) loop
1881
1882 -- For now we skip discriminants since it requires
1883 -- performing the analysis in two phases: first one
1884 -- analyzing discriminants and second one analyzing
1885 -- the rest of components since discriminants are
1886 -- evaluated prior to components: too much extra
1887 -- work to detect a corner case???
1888
1889 if Nkind (Choice) in N_Has_Entity
1890 and then Present (Entity (Choice))
1891 and then Ekind (Entity (Choice)) = E_Discriminant
1892 then
1893 null;
1894
1895 elsif Box_Present (Assoc) then
1896 null;
1897
1898 else
1899 if not Analyzed (Expression (Assoc)) then
1900 Comp_Expr :=
1901 New_Copy_Tree (Expression (Assoc));
1902 Set_Parent (Comp_Expr, Parent (N));
1903 Preanalyze_Without_Errors (Comp_Expr);
1904 else
1905 Comp_Expr := Expression (Assoc);
1906 end if;
1907
1908 Collect_Identifiers (Comp_Expr);
1909 end if;
1910
1911 Next (Choice);
1912 end loop;
1913 end if;
1914
1915 Next (Assoc);
1916 end loop;
1917 end if;
1918 end;
1919
1920 when others =>
1921 return;
1922 end case;
1923
1924 -- No further action needed if we already reported an error
1925
1926 if Present (Error_Node) then
1927 return;
1928 end if;
1929
1930 -- Check if some writable argument of a function is referenced
1931
1932 if Writable_Actuals_List /= No_Elist
1933 and then Identifiers_List /= No_Elist
1934 then
1935 declare
1936 Elmt_1 : Elmt_Id;
1937 Elmt_2 : Elmt_Id;
1938
1939 begin
1940 Elmt_1 := First_Elmt (Writable_Actuals_List);
1941 while Present (Elmt_1) loop
1942 Elmt_2 := First_Elmt (Identifiers_List);
1943 while Present (Elmt_2) loop
1944 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
1945 Error_Msg_N
1946 ("conflict of writable function parameter in construct "
1947 & "with arbitrary order of evaluation",
1948 Node (Elmt_1));
1949 end if;
1950
1951 Next_Elmt (Elmt_2);
1952 end loop;
1953
1954 Next_Elmt (Elmt_1);
1955 end loop;
1956 end;
1957 end if;
1958 end Check_Function_Writable_Actuals;
1959
1960 --------------------------------
1961 -- Check_Implicit_Dereference --
1962 --------------------------------
1963
1964 procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) is
1965 Disc : Entity_Id;
1966 Desig : Entity_Id;
1967
1968 begin
1969 if Ada_Version < Ada_2012
1970 or else not Has_Implicit_Dereference (Base_Type (Typ))
1971 then
1972 return;
1973
1974 elsif not Comes_From_Source (Nam) then
1975 return;
1976
1977 elsif Is_Entity_Name (Nam)
1978 and then Is_Type (Entity (Nam))
1979 then
1980 null;
1981
1982 else
1983 Disc := First_Discriminant (Typ);
1984 while Present (Disc) loop
1985 if Has_Implicit_Dereference (Disc) then
1986 Desig := Designated_Type (Etype (Disc));
1987 Add_One_Interp (Nam, Disc, Desig);
1988 exit;
1989 end if;
1990
1991 Next_Discriminant (Disc);
1992 end loop;
1993 end if;
1994 end Check_Implicit_Dereference;
1995
1996 ----------------------------------
1997 -- Check_Internal_Protected_Use --
1998 ----------------------------------
1999
2000 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
2001 S : Entity_Id;
2002 Prot : Entity_Id;
2003
2004 begin
2005 S := Current_Scope;
2006 while Present (S) loop
2007 if S = Standard_Standard then
2008 return;
2009
2010 elsif Ekind (S) = E_Function
2011 and then Ekind (Scope (S)) = E_Protected_Type
2012 then
2013 Prot := Scope (S);
2014 exit;
2015 end if;
2016
2017 S := Scope (S);
2018 end loop;
2019
2020 if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then
2021 if Nkind (N) = N_Subprogram_Renaming_Declaration then
2022 Error_Msg_N
2023 ("within protected function cannot use protected "
2024 & "procedure in renaming or as generic actual", N);
2025
2026 elsif Nkind (N) = N_Attribute_Reference then
2027 Error_Msg_N
2028 ("within protected function cannot take access of "
2029 & " protected procedure", N);
2030
2031 else
2032 Error_Msg_N
2033 ("within protected function, protected object is constant", N);
2034 Error_Msg_N
2035 ("\cannot call operation that may modify it", N);
2036 end if;
2037 end if;
2038 end Check_Internal_Protected_Use;
2039
2040 ---------------------------------------
2041 -- Check_Later_Vs_Basic_Declarations --
2042 ---------------------------------------
2043
2044 procedure Check_Later_Vs_Basic_Declarations
2045 (Decls : List_Id;
2046 During_Parsing : Boolean)
2047 is
2048 Body_Sloc : Source_Ptr;
2049 Decl : Node_Id;
2050
2051 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
2052 -- Return whether Decl is considered as a declarative item.
2053 -- When During_Parsing is True, the semantics of Ada 83 is followed.
2054 -- When During_Parsing is False, the semantics of SPARK is followed.
2055
2056 -------------------------------
2057 -- Is_Later_Declarative_Item --
2058 -------------------------------
2059
2060 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
2061 begin
2062 if Nkind (Decl) in N_Later_Decl_Item then
2063 return True;
2064
2065 elsif Nkind (Decl) = N_Pragma then
2066 return True;
2067
2068 elsif During_Parsing then
2069 return False;
2070
2071 -- In SPARK, a package declaration is not considered as a later
2072 -- declarative item.
2073
2074 elsif Nkind (Decl) = N_Package_Declaration then
2075 return False;
2076
2077 -- In SPARK, a renaming is considered as a later declarative item
2078
2079 elsif Nkind (Decl) in N_Renaming_Declaration then
2080 return True;
2081
2082 else
2083 return False;
2084 end if;
2085 end Is_Later_Declarative_Item;
2086
2087 -- Start of Check_Later_Vs_Basic_Declarations
2088
2089 begin
2090 Decl := First (Decls);
2091
2092 -- Loop through sequence of basic declarative items
2093
2094 Outer : while Present (Decl) loop
2095 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
2096 and then Nkind (Decl) not in N_Body_Stub
2097 then
2098 Next (Decl);
2099
2100 -- Once a body is encountered, we only allow later declarative
2101 -- items. The inner loop checks the rest of the list.
2102
2103 else
2104 Body_Sloc := Sloc (Decl);
2105
2106 Inner : while Present (Decl) loop
2107 if not Is_Later_Declarative_Item (Decl) then
2108 if During_Parsing then
2109 if Ada_Version = Ada_83 then
2110 Error_Msg_Sloc := Body_Sloc;
2111 Error_Msg_N
2112 ("(Ada 83) decl cannot appear after body#", Decl);
2113 end if;
2114 else
2115 Error_Msg_Sloc := Body_Sloc;
2116 Check_SPARK_Restriction
2117 ("decl cannot appear after body#", Decl);
2118 end if;
2119 end if;
2120
2121 Next (Decl);
2122 end loop Inner;
2123 end if;
2124 end loop Outer;
2125 end Check_Later_Vs_Basic_Declarations;
2126
2127 -------------------------
2128 -- Check_Nested_Access --
2129 -------------------------
2130
2131 procedure Check_Nested_Access (Ent : Entity_Id) is
2132 Scop : constant Entity_Id := Current_Scope;
2133 Current_Subp : Entity_Id;
2134 Enclosing : Entity_Id;
2135
2136 begin
2137 -- Currently only enabled for VM back-ends for efficiency, should we
2138 -- enable it more systematically ???
2139
2140 -- Check for Is_Imported needs commenting below ???
2141
2142 if VM_Target /= No_VM
2143 and then (Ekind (Ent) = E_Variable
2144 or else
2145 Ekind (Ent) = E_Constant
2146 or else
2147 Ekind (Ent) = E_Loop_Parameter)
2148 and then Scope (Ent) /= Empty
2149 and then not Is_Library_Level_Entity (Ent)
2150 and then not Is_Imported (Ent)
2151 then
2152 if Is_Subprogram (Scop)
2153 or else Is_Generic_Subprogram (Scop)
2154 or else Is_Entry (Scop)
2155 then
2156 Current_Subp := Scop;
2157 else
2158 Current_Subp := Current_Subprogram;
2159 end if;
2160
2161 Enclosing := Enclosing_Subprogram (Ent);
2162
2163 if Enclosing /= Empty
2164 and then Enclosing /= Current_Subp
2165 then
2166 Set_Has_Up_Level_Access (Ent, True);
2167 end if;
2168 end if;
2169 end Check_Nested_Access;
2170
2171 ---------------------------
2172 -- Check_No_Hidden_State --
2173 ---------------------------
2174
2175 procedure Check_No_Hidden_State (Id : Entity_Id) is
2176 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean;
2177 -- Determine whether the entity of a package denoted by Pkg has a null
2178 -- abstract state.
2179
2180 -----------------------------
2181 -- Has_Null_Abstract_State --
2182 -----------------------------
2183
2184 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is
2185 States : constant Elist_Id := Abstract_States (Pkg);
2186
2187 begin
2188 -- Check first available state of related package. A null abstract
2189 -- state always appears as the sole element of the state list.
2190
2191 return
2192 Present (States)
2193 and then Is_Null_State (Node (First_Elmt (States)));
2194 end Has_Null_Abstract_State;
2195
2196 -- Local variables
2197
2198 Context : Entity_Id := Empty;
2199 Not_Visible : Boolean := False;
2200 Scop : Entity_Id;
2201
2202 -- Start of processing for Check_No_Hidden_State
2203
2204 begin
2205 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
2206
2207 -- Find the proper context where the object or state appears
2208
2209 Scop := Scope (Id);
2210 while Present (Scop) loop
2211 Context := Scop;
2212
2213 -- Keep track of the context's visibility
2214
2215 Not_Visible := Not_Visible or else In_Private_Part (Context);
2216
2217 -- Prevent the search from going too far
2218
2219 if Context = Standard_Standard then
2220 return;
2221
2222 -- Objects and states that appear immediately within a subprogram or
2223 -- inside a construct nested within a subprogram do not introduce a
2224 -- hidden state. They behave as local variable declarations.
2225
2226 elsif Is_Subprogram (Context) then
2227 return;
2228
2229 -- When examining a package body, use the entity of the spec as it
2230 -- carries the abstract state declarations.
2231
2232 elsif Ekind (Context) = E_Package_Body then
2233 Context := Spec_Entity (Context);
2234 end if;
2235
2236 -- Stop the traversal when a package subject to a null abstract state
2237 -- has been found.
2238
2239 if Ekind_In (Context, E_Generic_Package, E_Package)
2240 and then Has_Null_Abstract_State (Context)
2241 then
2242 exit;
2243 end if;
2244
2245 Scop := Scope (Scop);
2246 end loop;
2247
2248 -- At this point we know that there is at least one package with a null
2249 -- abstract state in visibility. Emit an error message unconditionally
2250 -- if the entity being processed is a state because the placement of the
2251 -- related package is irrelevant. This is not the case for objects as
2252 -- the intermediate context matters.
2253
2254 if Present (Context)
2255 and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
2256 then
2257 Error_Msg_N ("cannot introduce hidden state &", Id);
2258 Error_Msg_NE ("\package & has null abstract state", Id, Context);
2259 end if;
2260 end Check_No_Hidden_State;
2261
2262 ------------------------------------------
2263 -- Check_Potentially_Blocking_Operation --
2264 ------------------------------------------
2265
2266 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
2267 S : Entity_Id;
2268
2269 begin
2270 -- N is one of the potentially blocking operations listed in 9.5.1(8).
2271 -- When pragma Detect_Blocking is active, the run time will raise
2272 -- Program_Error. Here we only issue a warning, since we generally
2273 -- support the use of potentially blocking operations in the absence
2274 -- of the pragma.
2275
2276 -- Indirect blocking through a subprogram call cannot be diagnosed
2277 -- statically without interprocedural analysis, so we do not attempt
2278 -- to do it here.
2279
2280 S := Scope (Current_Scope);
2281 while Present (S) and then S /= Standard_Standard loop
2282 if Is_Protected_Type (S) then
2283 Error_Msg_N
2284 ("potentially blocking operation in protected operation??", N);
2285 return;
2286 end if;
2287
2288 S := Scope (S);
2289 end loop;
2290 end Check_Potentially_Blocking_Operation;
2291
2292 ------------------------------
2293 -- Check_Unprotected_Access --
2294 ------------------------------
2295
2296 procedure Check_Unprotected_Access
2297 (Context : Node_Id;
2298 Expr : Node_Id)
2299 is
2300 Cont_Encl_Typ : Entity_Id;
2301 Pref_Encl_Typ : Entity_Id;
2302
2303 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
2304 -- Check whether Obj is a private component of a protected object.
2305 -- Return the protected type where the component resides, Empty
2306 -- otherwise.
2307
2308 function Is_Public_Operation return Boolean;
2309 -- Verify that the enclosing operation is callable from outside the
2310 -- protected object, to minimize false positives.
2311
2312 ------------------------------
2313 -- Enclosing_Protected_Type --
2314 ------------------------------
2315
2316 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
2317 begin
2318 if Is_Entity_Name (Obj) then
2319 declare
2320 Ent : Entity_Id := Entity (Obj);
2321
2322 begin
2323 -- The object can be a renaming of a private component, use
2324 -- the original record component.
2325
2326 if Is_Prival (Ent) then
2327 Ent := Prival_Link (Ent);
2328 end if;
2329
2330 if Is_Protected_Type (Scope (Ent)) then
2331 return Scope (Ent);
2332 end if;
2333 end;
2334 end if;
2335
2336 -- For indexed and selected components, recursively check the prefix
2337
2338 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
2339 return Enclosing_Protected_Type (Prefix (Obj));
2340
2341 -- The object does not denote a protected component
2342
2343 else
2344 return Empty;
2345 end if;
2346 end Enclosing_Protected_Type;
2347
2348 -------------------------
2349 -- Is_Public_Operation --
2350 -------------------------
2351
2352 function Is_Public_Operation return Boolean is
2353 S : Entity_Id;
2354 E : Entity_Id;
2355
2356 begin
2357 S := Current_Scope;
2358 while Present (S)
2359 and then S /= Pref_Encl_Typ
2360 loop
2361 if Scope (S) = Pref_Encl_Typ then
2362 E := First_Entity (Pref_Encl_Typ);
2363 while Present (E)
2364 and then E /= First_Private_Entity (Pref_Encl_Typ)
2365 loop
2366 if E = S then
2367 return True;
2368 end if;
2369 Next_Entity (E);
2370 end loop;
2371 end if;
2372
2373 S := Scope (S);
2374 end loop;
2375
2376 return False;
2377 end Is_Public_Operation;
2378
2379 -- Start of processing for Check_Unprotected_Access
2380
2381 begin
2382 if Nkind (Expr) = N_Attribute_Reference
2383 and then Attribute_Name (Expr) = Name_Unchecked_Access
2384 then
2385 Cont_Encl_Typ := Enclosing_Protected_Type (Context);
2386 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
2387
2388 -- Check whether we are trying to export a protected component to a
2389 -- context with an equal or lower access level.
2390
2391 if Present (Pref_Encl_Typ)
2392 and then No (Cont_Encl_Typ)
2393 and then Is_Public_Operation
2394 and then Scope_Depth (Pref_Encl_Typ) >=
2395 Object_Access_Level (Context)
2396 then
2397 Error_Msg_N
2398 ("??possible unprotected access to protected data", Expr);
2399 end if;
2400 end if;
2401 end Check_Unprotected_Access;
2402
2403 ---------------
2404 -- Check_VMS --
2405 ---------------
2406
2407 procedure Check_VMS (Construct : Node_Id) is
2408 begin
2409 if not OpenVMS_On_Target then
2410 Error_Msg_N
2411 ("this construct is allowed only in Open'V'M'S", Construct);
2412 end if;
2413 end Check_VMS;
2414
2415 ------------------------
2416 -- Collect_Interfaces --
2417 ------------------------
2418
2419 procedure Collect_Interfaces
2420 (T : Entity_Id;
2421 Ifaces_List : out Elist_Id;
2422 Exclude_Parents : Boolean := False;
2423 Use_Full_View : Boolean := True)
2424 is
2425 procedure Collect (Typ : Entity_Id);
2426 -- Subsidiary subprogram used to traverse the whole list
2427 -- of directly and indirectly implemented interfaces
2428
2429 -------------
2430 -- Collect --
2431 -------------
2432
2433 procedure Collect (Typ : Entity_Id) is
2434 Ancestor : Entity_Id;
2435 Full_T : Entity_Id;
2436 Id : Node_Id;
2437 Iface : Entity_Id;
2438
2439 begin
2440 Full_T := Typ;
2441
2442 -- Handle private types
2443
2444 if Use_Full_View
2445 and then Is_Private_Type (Typ)
2446 and then Present (Full_View (Typ))
2447 then
2448 Full_T := Full_View (Typ);
2449 end if;
2450
2451 -- Include the ancestor if we are generating the whole list of
2452 -- abstract interfaces.
2453
2454 if Etype (Full_T) /= Typ
2455
2456 -- Protect the frontend against wrong sources. For example:
2457
2458 -- package P is
2459 -- type A is tagged null record;
2460 -- type B is new A with private;
2461 -- type C is new A with private;
2462 -- private
2463 -- type B is new C with null record;
2464 -- type C is new B with null record;
2465 -- end P;
2466
2467 and then Etype (Full_T) /= T
2468 then
2469 Ancestor := Etype (Full_T);
2470 Collect (Ancestor);
2471
2472 if Is_Interface (Ancestor)
2473 and then not Exclude_Parents
2474 then
2475 Append_Unique_Elmt (Ancestor, Ifaces_List);
2476 end if;
2477 end if;
2478
2479 -- Traverse the graph of ancestor interfaces
2480
2481 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
2482 Id := First (Abstract_Interface_List (Full_T));
2483 while Present (Id) loop
2484 Iface := Etype (Id);
2485
2486 -- Protect against wrong uses. For example:
2487 -- type I is interface;
2488 -- type O is tagged null record;
2489 -- type Wrong is new I and O with null record; -- ERROR
2490
2491 if Is_Interface (Iface) then
2492 if Exclude_Parents
2493 and then Etype (T) /= T
2494 and then Interface_Present_In_Ancestor (Etype (T), Iface)
2495 then
2496 null;
2497 else
2498 Collect (Iface);
2499 Append_Unique_Elmt (Iface, Ifaces_List);
2500 end if;
2501 end if;
2502
2503 Next (Id);
2504 end loop;
2505 end if;
2506 end Collect;
2507
2508 -- Start of processing for Collect_Interfaces
2509
2510 begin
2511 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
2512 Ifaces_List := New_Elmt_List;
2513 Collect (T);
2514 end Collect_Interfaces;
2515
2516 ----------------------------------
2517 -- Collect_Interface_Components --
2518 ----------------------------------
2519
2520 procedure Collect_Interface_Components
2521 (Tagged_Type : Entity_Id;
2522 Components_List : out Elist_Id)
2523 is
2524 procedure Collect (Typ : Entity_Id);
2525 -- Subsidiary subprogram used to climb to the parents
2526
2527 -------------
2528 -- Collect --
2529 -------------
2530
2531 procedure Collect (Typ : Entity_Id) is
2532 Tag_Comp : Entity_Id;
2533 Parent_Typ : Entity_Id;
2534
2535 begin
2536 -- Handle private types
2537
2538 if Present (Full_View (Etype (Typ))) then
2539 Parent_Typ := Full_View (Etype (Typ));
2540 else
2541 Parent_Typ := Etype (Typ);
2542 end if;
2543
2544 if Parent_Typ /= Typ
2545
2546 -- Protect the frontend against wrong sources. For example:
2547
2548 -- package P is
2549 -- type A is tagged null record;
2550 -- type B is new A with private;
2551 -- type C is new A with private;
2552 -- private
2553 -- type B is new C with null record;
2554 -- type C is new B with null record;
2555 -- end P;
2556
2557 and then Parent_Typ /= Tagged_Type
2558 then
2559 Collect (Parent_Typ);
2560 end if;
2561
2562 -- Collect the components containing tags of secondary dispatch
2563 -- tables.
2564
2565 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
2566 while Present (Tag_Comp) loop
2567 pragma Assert (Present (Related_Type (Tag_Comp)));
2568 Append_Elmt (Tag_Comp, Components_List);
2569
2570 Tag_Comp := Next_Tag_Component (Tag_Comp);
2571 end loop;
2572 end Collect;
2573
2574 -- Start of processing for Collect_Interface_Components
2575
2576 begin
2577 pragma Assert (Ekind (Tagged_Type) = E_Record_Type
2578 and then Is_Tagged_Type (Tagged_Type));
2579
2580 Components_List := New_Elmt_List;
2581 Collect (Tagged_Type);
2582 end Collect_Interface_Components;
2583
2584 -----------------------------
2585 -- Collect_Interfaces_Info --
2586 -----------------------------
2587
2588 procedure Collect_Interfaces_Info
2589 (T : Entity_Id;
2590 Ifaces_List : out Elist_Id;
2591 Components_List : out Elist_Id;
2592 Tags_List : out Elist_Id)
2593 is
2594 Comps_List : Elist_Id;
2595 Comp_Elmt : Elmt_Id;
2596 Comp_Iface : Entity_Id;
2597 Iface_Elmt : Elmt_Id;
2598 Iface : Entity_Id;
2599
2600 function Search_Tag (Iface : Entity_Id) return Entity_Id;
2601 -- Search for the secondary tag associated with the interface type
2602 -- Iface that is implemented by T.
2603
2604 ----------------
2605 -- Search_Tag --
2606 ----------------
2607
2608 function Search_Tag (Iface : Entity_Id) return Entity_Id is
2609 ADT : Elmt_Id;
2610 begin
2611 if not Is_CPP_Class (T) then
2612 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
2613 else
2614 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
2615 end if;
2616
2617 while Present (ADT)
2618 and then Is_Tag (Node (ADT))
2619 and then Related_Type (Node (ADT)) /= Iface
2620 loop
2621 -- Skip secondary dispatch table referencing thunks to user
2622 -- defined primitives covered by this interface.
2623
2624 pragma Assert (Has_Suffix (Node (ADT), 'P'));
2625 Next_Elmt (ADT);
2626
2627 -- Skip secondary dispatch tables of Ada types
2628
2629 if not Is_CPP_Class (T) then
2630
2631 -- Skip secondary dispatch table referencing thunks to
2632 -- predefined primitives.
2633
2634 pragma Assert (Has_Suffix (Node (ADT), 'Y'));
2635 Next_Elmt (ADT);
2636
2637 -- Skip secondary dispatch table referencing user-defined
2638 -- primitives covered by this interface.
2639
2640 pragma Assert (Has_Suffix (Node (ADT), 'D'));
2641 Next_Elmt (ADT);
2642
2643 -- Skip secondary dispatch table referencing predefined
2644 -- primitives.
2645
2646 pragma Assert (Has_Suffix (Node (ADT), 'Z'));
2647 Next_Elmt (ADT);
2648 end if;
2649 end loop;
2650
2651 pragma Assert (Is_Tag (Node (ADT)));
2652 return Node (ADT);
2653 end Search_Tag;
2654
2655 -- Start of processing for Collect_Interfaces_Info
2656
2657 begin
2658 Collect_Interfaces (T, Ifaces_List);
2659 Collect_Interface_Components (T, Comps_List);
2660
2661 -- Search for the record component and tag associated with each
2662 -- interface type of T.
2663
2664 Components_List := New_Elmt_List;
2665 Tags_List := New_Elmt_List;
2666
2667 Iface_Elmt := First_Elmt (Ifaces_List);
2668 while Present (Iface_Elmt) loop
2669 Iface := Node (Iface_Elmt);
2670
2671 -- Associate the primary tag component and the primary dispatch table
2672 -- with all the interfaces that are parents of T
2673
2674 if Is_Ancestor (Iface, T, Use_Full_View => True) then
2675 Append_Elmt (First_Tag_Component (T), Components_List);
2676 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
2677
2678 -- Otherwise search for the tag component and secondary dispatch
2679 -- table of Iface
2680
2681 else
2682 Comp_Elmt := First_Elmt (Comps_List);
2683 while Present (Comp_Elmt) loop
2684 Comp_Iface := Related_Type (Node (Comp_Elmt));
2685
2686 if Comp_Iface = Iface
2687 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
2688 then
2689 Append_Elmt (Node (Comp_Elmt), Components_List);
2690 Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
2691 exit;
2692 end if;
2693
2694 Next_Elmt (Comp_Elmt);
2695 end loop;
2696 pragma Assert (Present (Comp_Elmt));
2697 end if;
2698
2699 Next_Elmt (Iface_Elmt);
2700 end loop;
2701 end Collect_Interfaces_Info;
2702
2703 ---------------------
2704 -- Collect_Parents --
2705 ---------------------
2706
2707 procedure Collect_Parents
2708 (T : Entity_Id;
2709 List : out Elist_Id;
2710 Use_Full_View : Boolean := True)
2711 is
2712 Current_Typ : Entity_Id := T;
2713 Parent_Typ : Entity_Id;
2714
2715 begin
2716 List := New_Elmt_List;
2717
2718 -- No action if the if the type has no parents
2719
2720 if T = Etype (T) then
2721 return;
2722 end if;
2723
2724 loop
2725 Parent_Typ := Etype (Current_Typ);
2726
2727 if Is_Private_Type (Parent_Typ)
2728 and then Present (Full_View (Parent_Typ))
2729 and then Use_Full_View
2730 then
2731 Parent_Typ := Full_View (Base_Type (Parent_Typ));
2732 end if;
2733
2734 Append_Elmt (Parent_Typ, List);
2735
2736 exit when Parent_Typ = Current_Typ;
2737 Current_Typ := Parent_Typ;
2738 end loop;
2739 end Collect_Parents;
2740
2741 ----------------------------------
2742 -- Collect_Primitive_Operations --
2743 ----------------------------------
2744
2745 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
2746 B_Type : constant Entity_Id := Base_Type (T);
2747 B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
2748 B_Scope : Entity_Id := Scope (B_Type);
2749 Op_List : Elist_Id;
2750 Formal : Entity_Id;
2751 Is_Prim : Boolean;
2752 Is_Type_In_Pkg : Boolean;
2753 Formal_Derived : Boolean := False;
2754 Id : Entity_Id;
2755
2756 function Match (E : Entity_Id) return Boolean;
2757 -- True if E's base type is B_Type, or E is of an anonymous access type
2758 -- and the base type of its designated type is B_Type.
2759
2760 -----------
2761 -- Match --
2762 -----------
2763
2764 function Match (E : Entity_Id) return Boolean is
2765 Etyp : Entity_Id := Etype (E);
2766
2767 begin
2768 if Ekind (Etyp) = E_Anonymous_Access_Type then
2769 Etyp := Designated_Type (Etyp);
2770 end if;
2771
2772 return Base_Type (Etyp) = B_Type;
2773 end Match;
2774
2775 -- Start of processing for Collect_Primitive_Operations
2776
2777 begin
2778 -- For tagged types, the primitive operations are collected as they
2779 -- are declared, and held in an explicit list which is simply returned.
2780
2781 if Is_Tagged_Type (B_Type) then
2782 return Primitive_Operations (B_Type);
2783
2784 -- An untagged generic type that is a derived type inherits the
2785 -- primitive operations of its parent type. Other formal types only
2786 -- have predefined operators, which are not explicitly represented.
2787
2788 elsif Is_Generic_Type (B_Type) then
2789 if Nkind (B_Decl) = N_Formal_Type_Declaration
2790 and then Nkind (Formal_Type_Definition (B_Decl))
2791 = N_Formal_Derived_Type_Definition
2792 then
2793 Formal_Derived := True;
2794 else
2795 return New_Elmt_List;
2796 end if;
2797 end if;
2798
2799 Op_List := New_Elmt_List;
2800
2801 if B_Scope = Standard_Standard then
2802 if B_Type = Standard_String then
2803 Append_Elmt (Standard_Op_Concat, Op_List);
2804
2805 elsif B_Type = Standard_Wide_String then
2806 Append_Elmt (Standard_Op_Concatw, Op_List);
2807
2808 else
2809 null;
2810 end if;
2811
2812 -- Locate the primitive subprograms of the type
2813
2814 else
2815 -- The primitive operations appear after the base type, except
2816 -- if the derivation happens within the private part of B_Scope
2817 -- and the type is a private type, in which case both the type
2818 -- and some primitive operations may appear before the base
2819 -- type, and the list of candidates starts after the type.
2820
2821 if In_Open_Scopes (B_Scope)
2822 and then Scope (T) = B_Scope
2823 and then In_Private_Part (B_Scope)
2824 then
2825 Id := Next_Entity (T);
2826 else
2827 Id := Next_Entity (B_Type);
2828 end if;
2829
2830 -- Set flag if this is a type in a package spec
2831
2832 Is_Type_In_Pkg :=
2833 Is_Package_Or_Generic_Package (B_Scope)
2834 and then
2835 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
2836 N_Package_Body;
2837
2838 while Present (Id) loop
2839
2840 -- Test whether the result type or any of the parameter types of
2841 -- each subprogram following the type match that type when the
2842 -- type is declared in a package spec, is a derived type, or the
2843 -- subprogram is marked as primitive. (The Is_Primitive test is
2844 -- needed to find primitives of nonderived types in declarative
2845 -- parts that happen to override the predefined "=" operator.)
2846
2847 -- Note that generic formal subprograms are not considered to be
2848 -- primitive operations and thus are never inherited.
2849
2850 if Is_Overloadable (Id)
2851 and then (Is_Type_In_Pkg
2852 or else Is_Derived_Type (B_Type)
2853 or else Is_Primitive (Id))
2854 and then Nkind (Parent (Parent (Id)))
2855 not in N_Formal_Subprogram_Declaration
2856 then
2857 Is_Prim := False;
2858
2859 if Match (Id) then
2860 Is_Prim := True;
2861
2862 else
2863 Formal := First_Formal (Id);
2864 while Present (Formal) loop
2865 if Match (Formal) then
2866 Is_Prim := True;
2867 exit;
2868 end if;
2869
2870 Next_Formal (Formal);
2871 end loop;
2872 end if;
2873
2874 -- For a formal derived type, the only primitives are the ones
2875 -- inherited from the parent type. Operations appearing in the
2876 -- package declaration are not primitive for it.
2877
2878 if Is_Prim
2879 and then (not Formal_Derived
2880 or else Present (Alias (Id)))
2881 then
2882 -- In the special case of an equality operator aliased to
2883 -- an overriding dispatching equality belonging to the same
2884 -- type, we don't include it in the list of primitives.
2885 -- This avoids inheriting multiple equality operators when
2886 -- deriving from untagged private types whose full type is
2887 -- tagged, which can otherwise cause ambiguities. Note that
2888 -- this should only happen for this kind of untagged parent
2889 -- type, since normally dispatching operations are inherited
2890 -- using the type's Primitive_Operations list.
2891
2892 if Chars (Id) = Name_Op_Eq
2893 and then Is_Dispatching_Operation (Id)
2894 and then Present (Alias (Id))
2895 and then Present (Overridden_Operation (Alias (Id)))
2896 and then Base_Type (Etype (First_Entity (Id))) =
2897 Base_Type (Etype (First_Entity (Alias (Id))))
2898 then
2899 null;
2900
2901 -- Include the subprogram in the list of primitives
2902
2903 else
2904 Append_Elmt (Id, Op_List);
2905 end if;
2906 end if;
2907 end if;
2908
2909 Next_Entity (Id);
2910
2911 -- For a type declared in System, some of its operations may
2912 -- appear in the target-specific extension to System.
2913
2914 if No (Id)
2915 and then B_Scope = RTU_Entity (System)
2916 and then Present_System_Aux
2917 then
2918 B_Scope := System_Aux_Id;
2919 Id := First_Entity (System_Aux_Id);
2920 end if;
2921 end loop;
2922 end if;
2923
2924 return Op_List;
2925 end Collect_Primitive_Operations;
2926
2927 -----------------------------------
2928 -- Compile_Time_Constraint_Error --
2929 -----------------------------------
2930
2931 function Compile_Time_Constraint_Error
2932 (N : Node_Id;
2933 Msg : String;
2934 Ent : Entity_Id := Empty;
2935 Loc : Source_Ptr := No_Location;
2936 Warn : Boolean := False) return Node_Id
2937 is
2938 Msgc : String (1 .. Msg'Length + 3);
2939 -- Copy of message, with room for possible ?? and ! at end
2940
2941 Msgl : Natural;
2942 Wmsg : Boolean;
2943 P : Node_Id;
2944 OldP : Node_Id;
2945 Msgs : Boolean;
2946 Eloc : Source_Ptr;
2947
2948 begin
2949 -- A static constraint error in an instance body is not a fatal error.
2950 -- we choose to inhibit the message altogether, because there is no
2951 -- obvious node (for now) on which to post it. On the other hand the
2952 -- offending node must be replaced with a constraint_error in any case.
2953
2954 -- No messages are generated if we already posted an error on this node
2955
2956 if not Error_Posted (N) then
2957 if Loc /= No_Location then
2958 Eloc := Loc;
2959 else
2960 Eloc := Sloc (N);
2961 end if;
2962
2963 Msgc (1 .. Msg'Length) := Msg;
2964 Msgl := Msg'Length;
2965
2966 -- Message is a warning, even in Ada 95 case
2967
2968 if Msg (Msg'Last) = '?' then
2969 Wmsg := True;
2970
2971 -- In Ada 83, all messages are warnings. In the private part and
2972 -- the body of an instance, constraint_checks are only warnings.
2973 -- We also make this a warning if the Warn parameter is set.
2974
2975 elsif Warn
2976 or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
2977 then
2978 Msgl := Msgl + 1;
2979 Msgc (Msgl) := '?';
2980 Msgl := Msgl + 1;
2981 Msgc (Msgl) := '?';
2982 Wmsg := True;
2983
2984 elsif In_Instance_Not_Visible then
2985 Msgl := Msgl + 1;
2986 Msgc (Msgl) := '?';
2987 Msgl := Msgl + 1;
2988 Msgc (Msgl) := '?';
2989 Wmsg := True;
2990
2991 -- Otherwise we have a real error message (Ada 95 static case)
2992 -- and we make this an unconditional message. Note that in the
2993 -- warning case we do not make the message unconditional, it seems
2994 -- quite reasonable to delete messages like this (about exceptions
2995 -- that will be raised) in dead code.
2996
2997 else
2998 Wmsg := False;
2999 Msgl := Msgl + 1;
3000 Msgc (Msgl) := '!';
3001 end if;
3002
3003 -- Should we generate a warning? The answer is not quite yes. The
3004 -- very annoying exception occurs in the case of a short circuit
3005 -- operator where the left operand is static and decisive. Climb
3006 -- parents to see if that is the case we have here. Conditional
3007 -- expressions with decisive conditions are a similar situation.
3008
3009 Msgs := True;
3010 P := N;
3011 loop
3012 OldP := P;
3013 P := Parent (P);
3014
3015 -- And then with False as left operand
3016
3017 if Nkind (P) = N_And_Then
3018 and then Compile_Time_Known_Value (Left_Opnd (P))
3019 and then Is_False (Expr_Value (Left_Opnd (P)))
3020 then
3021 Msgs := False;
3022 exit;
3023
3024 -- OR ELSE with True as left operand
3025
3026 elsif Nkind (P) = N_Or_Else
3027 and then Compile_Time_Known_Value (Left_Opnd (P))
3028 and then Is_True (Expr_Value (Left_Opnd (P)))
3029 then
3030 Msgs := False;
3031 exit;
3032
3033 -- If expression
3034
3035 elsif Nkind (P) = N_If_Expression then
3036 declare
3037 Cond : constant Node_Id := First (Expressions (P));
3038 Texp : constant Node_Id := Next (Cond);
3039 Fexp : constant Node_Id := Next (Texp);
3040
3041 begin
3042 if Compile_Time_Known_Value (Cond) then
3043
3044 -- Condition is True and we are in the right operand
3045
3046 if Is_True (Expr_Value (Cond))
3047 and then OldP = Fexp
3048 then
3049 Msgs := False;
3050 exit;
3051
3052 -- Condition is False and we are in the left operand
3053
3054 elsif Is_False (Expr_Value (Cond))
3055 and then OldP = Texp
3056 then
3057 Msgs := False;
3058 exit;
3059 end if;
3060 end if;
3061 end;
3062
3063 -- Special case for component association in aggregates, where
3064 -- we want to keep climbing up to the parent aggregate.
3065
3066 elsif Nkind (P) = N_Component_Association
3067 and then Nkind (Parent (P)) = N_Aggregate
3068 then
3069 null;
3070
3071 -- Keep going if within subexpression
3072
3073 else
3074 exit when Nkind (P) not in N_Subexpr;
3075 end if;
3076 end loop;
3077
3078 if Msgs then
3079 if Present (Ent) then
3080 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
3081 else
3082 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
3083 end if;
3084
3085 if Wmsg then
3086
3087 -- Check whether the context is an Init_Proc
3088
3089 if Inside_Init_Proc then
3090 declare
3091 Conc_Typ : constant Entity_Id :=
3092 Corresponding_Concurrent_Type
3093 (Entity (Parameter_Type (First
3094 (Parameter_Specifications
3095 (Parent (Current_Scope))))));
3096
3097 begin
3098 -- Don't complain if the corresponding concurrent type
3099 -- doesn't come from source (i.e. a single task/protected
3100 -- object).
3101
3102 if Present (Conc_Typ)
3103 and then not Comes_From_Source (Conc_Typ)
3104 then
3105 Error_Msg_NEL
3106 ("\??& will be raised at run time",
3107 N, Standard_Constraint_Error, Eloc);
3108
3109 else
3110 Error_Msg_NEL
3111 ("\??& will be raised for objects of this type",
3112 N, Standard_Constraint_Error, Eloc);
3113 end if;
3114 end;
3115
3116 else
3117 Error_Msg_NEL
3118 ("\??& will be raised at run time",
3119 N, Standard_Constraint_Error, Eloc);
3120 end if;
3121
3122 else
3123 Error_Msg
3124 ("\static expression fails Constraint_Check", Eloc);
3125 Set_Error_Posted (N);
3126 end if;
3127 end if;
3128 end if;
3129
3130 return N;
3131 end Compile_Time_Constraint_Error;
3132
3133 -----------------------
3134 -- Conditional_Delay --
3135 -----------------------
3136
3137 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
3138 begin
3139 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
3140 Set_Has_Delayed_Freeze (New_Ent);
3141 end if;
3142 end Conditional_Delay;
3143
3144 -------------------------
3145 -- Copy_Component_List --
3146 -------------------------
3147
3148 function Copy_Component_List
3149 (R_Typ : Entity_Id;
3150 Loc : Source_Ptr) return List_Id
3151 is
3152 Comp : Node_Id;
3153 Comps : constant List_Id := New_List;
3154
3155 begin
3156 Comp := First_Component (Underlying_Type (R_Typ));
3157 while Present (Comp) loop
3158 if Comes_From_Source (Comp) then
3159 declare
3160 Comp_Decl : constant Node_Id := Declaration_Node (Comp);
3161 begin
3162 Append_To (Comps,
3163 Make_Component_Declaration (Loc,
3164 Defining_Identifier =>
3165 Make_Defining_Identifier (Loc, Chars (Comp)),
3166 Component_Definition =>
3167 New_Copy_Tree
3168 (Component_Definition (Comp_Decl), New_Sloc => Loc)));
3169 end;
3170 end if;
3171
3172 Next_Component (Comp);
3173 end loop;
3174
3175 return Comps;
3176 end Copy_Component_List;
3177
3178 -------------------------
3179 -- Copy_Parameter_List --
3180 -------------------------
3181
3182 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
3183 Loc : constant Source_Ptr := Sloc (Subp_Id);
3184 Plist : List_Id;
3185 Formal : Entity_Id;
3186
3187 begin
3188 if No (First_Formal (Subp_Id)) then
3189 return No_List;
3190 else
3191 Plist := New_List;
3192 Formal := First_Formal (Subp_Id);
3193 while Present (Formal) loop
3194 Append
3195 (Make_Parameter_Specification (Loc,
3196 Defining_Identifier =>
3197 Make_Defining_Identifier (Sloc (Formal),
3198 Chars => Chars (Formal)),
3199 In_Present => In_Present (Parent (Formal)),
3200 Out_Present => Out_Present (Parent (Formal)),
3201 Parameter_Type =>
3202 New_Reference_To (Etype (Formal), Loc),
3203 Expression =>
3204 New_Copy_Tree (Expression (Parent (Formal)))),
3205 Plist);
3206
3207 Next_Formal (Formal);
3208 end loop;
3209 end if;
3210
3211 return Plist;
3212 end Copy_Parameter_List;
3213
3214 --------------------------------
3215 -- Corresponding_Generic_Type --
3216 --------------------------------
3217
3218 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
3219 Inst : Entity_Id;
3220 Gen : Entity_Id;
3221 Typ : Entity_Id;
3222
3223 begin
3224 if not Is_Generic_Actual_Type (T) then
3225 return Any_Type;
3226
3227 -- If the actual is the actual of an enclosing instance, resolution
3228 -- was correct in the generic.
3229
3230 elsif Nkind (Parent (T)) = N_Subtype_Declaration
3231 and then Is_Entity_Name (Subtype_Indication (Parent (T)))
3232 and then
3233 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T))))
3234 then
3235 return Any_Type;
3236
3237 else
3238 Inst := Scope (T);
3239
3240 if Is_Wrapper_Package (Inst) then
3241 Inst := Related_Instance (Inst);
3242 end if;
3243
3244 Gen :=
3245 Generic_Parent
3246 (Specification (Unit_Declaration_Node (Inst)));
3247
3248 -- Generic actual has the same name as the corresponding formal
3249
3250 Typ := First_Entity (Gen);
3251 while Present (Typ) loop
3252 if Chars (Typ) = Chars (T) then
3253 return Typ;
3254 end if;
3255
3256 Next_Entity (Typ);
3257 end loop;
3258
3259 return Any_Type;
3260 end if;
3261 end Corresponding_Generic_Type;
3262
3263 --------------------
3264 -- Current_Entity --
3265 --------------------
3266
3267 -- The currently visible definition for a given identifier is the
3268 -- one most chained at the start of the visibility chain, i.e. the
3269 -- one that is referenced by the Node_Id value of the name of the
3270 -- given identifier.
3271
3272 function Current_Entity (N : Node_Id) return Entity_Id is
3273 begin
3274 return Get_Name_Entity_Id (Chars (N));
3275 end Current_Entity;
3276
3277 -----------------------------
3278 -- Current_Entity_In_Scope --
3279 -----------------------------
3280
3281 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
3282 E : Entity_Id;
3283 CS : constant Entity_Id := Current_Scope;
3284
3285 Transient_Case : constant Boolean := Scope_Is_Transient;
3286
3287 begin
3288 E := Get_Name_Entity_Id (Chars (N));
3289 while Present (E)
3290 and then Scope (E) /= CS
3291 and then (not Transient_Case or else Scope (E) /= Scope (CS))
3292 loop
3293 E := Homonym (E);
3294 end loop;
3295
3296 return E;
3297 end Current_Entity_In_Scope;
3298
3299 -------------------
3300 -- Current_Scope --
3301 -------------------
3302
3303 function Current_Scope return Entity_Id is
3304 begin
3305 if Scope_Stack.Last = -1 then
3306 return Standard_Standard;
3307 else
3308 declare
3309 C : constant Entity_Id :=
3310 Scope_Stack.Table (Scope_Stack.Last).Entity;
3311 begin
3312 if Present (C) then
3313 return C;
3314 else
3315 return Standard_Standard;
3316 end if;
3317 end;
3318 end if;
3319 end Current_Scope;
3320
3321 ------------------------
3322 -- Current_Subprogram --
3323 ------------------------
3324
3325 function Current_Subprogram return Entity_Id is
3326 Scop : constant Entity_Id := Current_Scope;
3327 begin
3328 if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
3329 return Scop;
3330 else
3331 return Enclosing_Subprogram (Scop);
3332 end if;
3333 end Current_Subprogram;
3334
3335 ----------------------------------
3336 -- Deepest_Type_Access_Level --
3337 ----------------------------------
3338
3339 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
3340 begin
3341 if Ekind (Typ) = E_Anonymous_Access_Type
3342 and then not Is_Local_Anonymous_Access (Typ)
3343 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
3344 then
3345 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
3346 -- access type.
3347
3348 return
3349 Scope_Depth (Enclosing_Dynamic_Scope
3350 (Defining_Identifier
3351 (Associated_Node_For_Itype (Typ))));
3352
3353 -- For generic formal type, return Int'Last (infinite).
3354 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
3355
3356 elsif Is_Generic_Type (Root_Type (Typ)) then
3357 return UI_From_Int (Int'Last);
3358
3359 else
3360 return Type_Access_Level (Typ);
3361 end if;
3362 end Deepest_Type_Access_Level;
3363
3364 ---------------------
3365 -- Defining_Entity --
3366 ---------------------
3367
3368 function Defining_Entity (N : Node_Id) return Entity_Id is
3369 K : constant Node_Kind := Nkind (N);
3370 Err : Entity_Id := Empty;
3371
3372 begin
3373 case K is
3374 when
3375 N_Subprogram_Declaration |
3376 N_Abstract_Subprogram_Declaration |
3377 N_Subprogram_Body |
3378 N_Package_Declaration |
3379 N_Subprogram_Renaming_Declaration |
3380 N_Subprogram_Body_Stub |
3381 N_Generic_Subprogram_Declaration |
3382 N_Generic_Package_Declaration |
3383 N_Formal_Subprogram_Declaration |
3384 N_Expression_Function
3385 =>
3386 return Defining_Entity (Specification (N));
3387
3388 when
3389 N_Component_Declaration |
3390 N_Defining_Program_Unit_Name |
3391 N_Discriminant_Specification |
3392 N_Entry_Body |
3393 N_Entry_Declaration |
3394 N_Entry_Index_Specification |
3395 N_Exception_Declaration |
3396 N_Exception_Renaming_Declaration |
3397 N_Formal_Object_Declaration |
3398 N_Formal_Package_Declaration |
3399 N_Formal_Type_Declaration |
3400 N_Full_Type_Declaration |
3401 N_Implicit_Label_Declaration |
3402 N_Incomplete_Type_Declaration |
3403 N_Loop_Parameter_Specification |
3404 N_Number_Declaration |
3405 N_Object_Declaration |
3406 N_Object_Renaming_Declaration |
3407 N_Package_Body_Stub |
3408 N_Parameter_Specification |
3409 N_Private_Extension_Declaration |
3410 N_Private_Type_Declaration |
3411 N_Protected_Body |
3412 N_Protected_Body_Stub |
3413 N_Protected_Type_Declaration |
3414 N_Single_Protected_Declaration |
3415 N_Single_Task_Declaration |
3416 N_Subtype_Declaration |
3417 N_Task_Body |
3418 N_Task_Body_Stub |
3419 N_Task_Type_Declaration
3420 =>
3421 return Defining_Identifier (N);
3422
3423 when N_Subunit =>
3424 return Defining_Entity (Proper_Body (N));
3425
3426 when
3427 N_Function_Instantiation |
3428 N_Function_Specification |
3429 N_Generic_Function_Renaming_Declaration |
3430 N_Generic_Package_Renaming_Declaration |
3431 N_Generic_Procedure_Renaming_Declaration |
3432 N_Package_Body |
3433 N_Package_Instantiation |
3434 N_Package_Renaming_Declaration |
3435 N_Package_Specification |
3436 N_Procedure_Instantiation |
3437 N_Procedure_Specification
3438 =>
3439 declare
3440 Nam : constant Node_Id := Defining_Unit_Name (N);
3441
3442 begin
3443 if Nkind (Nam) in N_Entity then
3444 return Nam;
3445
3446 -- For Error, make up a name and attach to declaration
3447 -- so we can continue semantic analysis
3448
3449 elsif Nam = Error then
3450 Err := Make_Temporary (Sloc (N), 'T');
3451 Set_Defining_Unit_Name (N, Err);
3452
3453 return Err;
3454 -- If not an entity, get defining identifier
3455
3456 else
3457 return Defining_Identifier (Nam);
3458 end if;
3459 end;
3460
3461 when N_Block_Statement =>
3462 return Entity (Identifier (N));
3463
3464 when others =>
3465 raise Program_Error;
3466
3467 end case;
3468 end Defining_Entity;
3469
3470 --------------------------
3471 -- Denotes_Discriminant --
3472 --------------------------
3473
3474 function Denotes_Discriminant
3475 (N : Node_Id;
3476 Check_Concurrent : Boolean := False) return Boolean
3477 is
3478 E : Entity_Id;
3479 begin
3480 if not Is_Entity_Name (N)
3481 or else No (Entity (N))
3482 then
3483 return False;
3484 else
3485 E := Entity (N);
3486 end if;
3487
3488 -- If we are checking for a protected type, the discriminant may have
3489 -- been rewritten as the corresponding discriminal of the original type
3490 -- or of the corresponding concurrent record, depending on whether we
3491 -- are in the spec or body of the protected type.
3492
3493 return Ekind (E) = E_Discriminant
3494 or else
3495 (Check_Concurrent
3496 and then Ekind (E) = E_In_Parameter
3497 and then Present (Discriminal_Link (E))
3498 and then
3499 (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
3500 or else
3501 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
3502
3503 end Denotes_Discriminant;
3504
3505 -------------------------
3506 -- Denotes_Same_Object --
3507 -------------------------
3508
3509 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
3510 Obj1 : Node_Id := A1;
3511 Obj2 : Node_Id := A2;
3512
3513 function Has_Prefix (N : Node_Id) return Boolean;
3514 -- Return True if N has attribute Prefix
3515
3516 function Is_Renaming (N : Node_Id) return Boolean;
3517 -- Return true if N names a renaming entity
3518
3519 function Is_Valid_Renaming (N : Node_Id) return Boolean;
3520 -- For renamings, return False if the prefix of any dereference within
3521 -- the renamed object_name is a variable, or any expression within the
3522 -- renamed object_name contains references to variables or calls on
3523 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
3524
3525 ----------------
3526 -- Has_Prefix --
3527 ----------------
3528
3529 function Has_Prefix (N : Node_Id) return Boolean is
3530 begin
3531 return
3532 Nkind_In (N,
3533 N_Attribute_Reference,
3534 N_Expanded_Name,
3535 N_Explicit_Dereference,
3536 N_Indexed_Component,
3537 N_Reference,
3538 N_Selected_Component,
3539 N_Slice);
3540 end Has_Prefix;
3541
3542 -----------------
3543 -- Is_Renaming --
3544 -----------------
3545
3546 function Is_Renaming (N : Node_Id) return Boolean is
3547 begin
3548 return Is_Entity_Name (N)
3549 and then Present (Renamed_Entity (Entity (N)));
3550 end Is_Renaming;
3551
3552 -----------------------
3553 -- Is_Valid_Renaming --
3554 -----------------------
3555
3556 function Is_Valid_Renaming (N : Node_Id) return Boolean is
3557
3558 function Check_Renaming (N : Node_Id) return Boolean;
3559 -- Recursive function used to traverse all the prefixes of N
3560
3561 function Check_Renaming (N : Node_Id) return Boolean is
3562 begin
3563 if Is_Renaming (N)
3564 and then not Check_Renaming (Renamed_Entity (Entity (N)))
3565 then
3566 return False;
3567 end if;
3568
3569 if Nkind (N) = N_Indexed_Component then
3570 declare
3571 Indx : Node_Id;
3572
3573 begin
3574 Indx := First (Expressions (N));
3575 while Present (Indx) loop
3576 if not Is_OK_Static_Expression (Indx) then
3577 return False;
3578 end if;
3579
3580 Next_Index (Indx);
3581 end loop;
3582 end;
3583 end if;
3584
3585 if Has_Prefix (N) then
3586 declare
3587 P : constant Node_Id := Prefix (N);
3588
3589 begin
3590 if Nkind (N) = N_Explicit_Dereference
3591 and then Is_Variable (P)
3592 then
3593 return False;
3594
3595 elsif Is_Entity_Name (P)
3596 and then Ekind (Entity (P)) = E_Function
3597 then
3598 return False;
3599
3600 elsif Nkind (P) = N_Function_Call then
3601 return False;
3602 end if;
3603
3604 -- Recursion to continue traversing the prefix of the
3605 -- renaming expression
3606
3607 return Check_Renaming (P);
3608 end;
3609 end if;
3610
3611 return True;
3612 end Check_Renaming;
3613
3614 -- Start of processing for Is_Valid_Renaming
3615
3616 begin
3617 return Check_Renaming (N);
3618 end Is_Valid_Renaming;
3619
3620 -- Start of processing for Denotes_Same_Object
3621
3622 begin
3623 -- Both names statically denote the same stand-alone object or parameter
3624 -- (RM 6.4.1(6.5/3))
3625
3626 if Is_Entity_Name (Obj1)
3627 and then Is_Entity_Name (Obj2)
3628 and then Entity (Obj1) = Entity (Obj2)
3629 then
3630 return True;
3631 end if;
3632
3633 -- For renamings, the prefix of any dereference within the renamed
3634 -- object_name is not a variable, and any expression within the
3635 -- renamed object_name contains no references to variables nor
3636 -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
3637
3638 if Is_Renaming (Obj1) then
3639 if Is_Valid_Renaming (Obj1) then
3640 Obj1 := Renamed_Entity (Entity (Obj1));
3641 else
3642 return False;
3643 end if;
3644 end if;
3645
3646 if Is_Renaming (Obj2) then
3647 if Is_Valid_Renaming (Obj2) then
3648 Obj2 := Renamed_Entity (Entity (Obj2));
3649 else
3650 return False;
3651 end if;
3652 end if;
3653
3654 -- No match if not same node kind (such cases are handled by
3655 -- Denotes_Same_Prefix)
3656
3657 if Nkind (Obj1) /= Nkind (Obj2) then
3658 return False;
3659
3660 -- After handling valid renamings, one of the two names statically
3661 -- denoted a renaming declaration whose renamed object_name is known
3662 -- to denote the same object as the other (RM 6.4.1(6.10/3))
3663
3664 elsif Is_Entity_Name (Obj1) then
3665 if Is_Entity_Name (Obj2) then
3666 return Entity (Obj1) = Entity (Obj2);
3667 else
3668 return False;
3669 end if;
3670
3671 -- Both names are selected_components, their prefixes are known to
3672 -- denote the same object, and their selector_names denote the same
3673 -- component (RM 6.4.1(6.6/3)
3674
3675 elsif Nkind (Obj1) = N_Selected_Component then
3676 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
3677 and then
3678 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
3679
3680 -- Both names are dereferences and the dereferenced names are known to
3681 -- denote the same object (RM 6.4.1(6.7/3))
3682
3683 elsif Nkind (Obj1) = N_Explicit_Dereference then
3684 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
3685
3686 -- Both names are indexed_components, their prefixes are known to denote
3687 -- the same object, and each of the pairs of corresponding index values
3688 -- are either both static expressions with the same static value or both
3689 -- names that are known to denote the same object (RM 6.4.1(6.8/3))
3690
3691 elsif Nkind (Obj1) = N_Indexed_Component then
3692 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
3693 return False;
3694 else
3695 declare
3696 Indx1 : Node_Id;
3697 Indx2 : Node_Id;
3698
3699 begin
3700 Indx1 := First (Expressions (Obj1));
3701 Indx2 := First (Expressions (Obj2));
3702 while Present (Indx1) loop
3703
3704 -- Indexes must denote the same static value or same object
3705
3706 if Is_OK_Static_Expression (Indx1) then
3707 if not Is_OK_Static_Expression (Indx2) then
3708 return False;
3709
3710 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
3711 return False;
3712 end if;
3713
3714 elsif not Denotes_Same_Object (Indx1, Indx2) then
3715 return False;
3716 end if;
3717
3718 Next (Indx1);
3719 Next (Indx2);
3720 end loop;
3721
3722 return True;
3723 end;
3724 end if;
3725
3726 -- Both names are slices, their prefixes are known to denote the same
3727 -- object, and the two slices have statically matching index constraints
3728 -- (RM 6.4.1(6.9/3))
3729
3730 elsif Nkind (Obj1) = N_Slice
3731 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
3732 then
3733 declare
3734 Lo1, Lo2, Hi1, Hi2 : Node_Id;
3735
3736 begin
3737 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
3738 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
3739
3740 -- Check whether bounds are statically identical. There is no
3741 -- attempt to detect partial overlap of slices.
3742
3743 return Denotes_Same_Object (Lo1, Lo2)
3744 and then Denotes_Same_Object (Hi1, Hi2);
3745 end;
3746
3747 -- In the recursion, literals appear as indexes.
3748
3749 elsif Nkind (Obj1) = N_Integer_Literal
3750 and then Nkind (Obj2) = N_Integer_Literal
3751 then
3752 return Intval (Obj1) = Intval (Obj2);
3753
3754 else
3755 return False;
3756 end if;
3757 end Denotes_Same_Object;
3758
3759 -------------------------
3760 -- Denotes_Same_Prefix --
3761 -------------------------
3762
3763 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
3764
3765 begin
3766 if Is_Entity_Name (A1) then
3767 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
3768 and then not Is_Access_Type (Etype (A1))
3769 then
3770 return Denotes_Same_Object (A1, Prefix (A2))
3771 or else Denotes_Same_Prefix (A1, Prefix (A2));
3772 else
3773 return False;
3774 end if;
3775
3776 elsif Is_Entity_Name (A2) then
3777 return Denotes_Same_Prefix (A1 => A2, A2 => A1);
3778
3779 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
3780 and then
3781 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
3782 then
3783 declare
3784 Root1, Root2 : Node_Id;
3785 Depth1, Depth2 : Int := 0;
3786
3787 begin
3788 Root1 := Prefix (A1);
3789 while not Is_Entity_Name (Root1) loop
3790 if not Nkind_In
3791 (Root1, N_Selected_Component, N_Indexed_Component)
3792 then
3793 return False;
3794 else
3795 Root1 := Prefix (Root1);
3796 end if;
3797
3798 Depth1 := Depth1 + 1;
3799 end loop;
3800
3801 Root2 := Prefix (A2);
3802 while not Is_Entity_Name (Root2) loop
3803 if not Nkind_In
3804 (Root2, N_Selected_Component, N_Indexed_Component)
3805 then
3806 return False;
3807 else
3808 Root2 := Prefix (Root2);
3809 end if;
3810
3811 Depth2 := Depth2 + 1;
3812 end loop;
3813
3814 -- If both have the same depth and they do not denote the same
3815 -- object, they are disjoint and no warning is needed.
3816
3817 if Depth1 = Depth2 then
3818 return False;
3819
3820 elsif Depth1 > Depth2 then
3821 Root1 := Prefix (A1);
3822 for I in 1 .. Depth1 - Depth2 - 1 loop
3823 Root1 := Prefix (Root1);
3824 end loop;
3825
3826 return Denotes_Same_Object (Root1, A2);
3827
3828 else
3829 Root2 := Prefix (A2);
3830 for I in 1 .. Depth2 - Depth1 - 1 loop
3831 Root2 := Prefix (Root2);
3832 end loop;
3833
3834 return Denotes_Same_Object (A1, Root2);
3835 end if;
3836 end;
3837
3838 else
3839 return False;
3840 end if;
3841 end Denotes_Same_Prefix;
3842
3843 ----------------------
3844 -- Denotes_Variable --
3845 ----------------------
3846
3847 function Denotes_Variable (N : Node_Id) return Boolean is
3848 begin
3849 return Is_Variable (N) and then Paren_Count (N) = 0;
3850 end Denotes_Variable;
3851
3852 -----------------------------
3853 -- Depends_On_Discriminant --
3854 -----------------------------
3855
3856 function Depends_On_Discriminant (N : Node_Id) return Boolean is
3857 L : Node_Id;
3858 H : Node_Id;
3859
3860 begin
3861 Get_Index_Bounds (N, L, H);
3862 return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
3863 end Depends_On_Discriminant;
3864
3865 -------------------------
3866 -- Designate_Same_Unit --
3867 -------------------------
3868
3869 function Designate_Same_Unit
3870 (Name1 : Node_Id;
3871 Name2 : Node_Id) return Boolean
3872 is
3873 K1 : constant Node_Kind := Nkind (Name1);
3874 K2 : constant Node_Kind := Nkind (Name2);
3875
3876 function Prefix_Node (N : Node_Id) return Node_Id;
3877 -- Returns the parent unit name node of a defining program unit name
3878 -- or the prefix if N is a selected component or an expanded name.
3879
3880 function Select_Node (N : Node_Id) return Node_Id;
3881 -- Returns the defining identifier node of a defining program unit
3882 -- name or the selector node if N is a selected component or an
3883 -- expanded name.
3884
3885 -----------------
3886 -- Prefix_Node --
3887 -----------------
3888
3889 function Prefix_Node (N : Node_Id) return Node_Id is
3890 begin
3891 if Nkind (N) = N_Defining_Program_Unit_Name then
3892 return Name (N);
3893
3894 else
3895 return Prefix (N);
3896 end if;
3897 end Prefix_Node;
3898
3899 -----------------
3900 -- Select_Node --
3901 -----------------
3902
3903 function Select_Node (N : Node_Id) return Node_Id is
3904 begin
3905 if Nkind (N) = N_Defining_Program_Unit_Name then
3906 return Defining_Identifier (N);
3907
3908 else
3909 return Selector_Name (N);
3910 end if;
3911 end Select_Node;
3912
3913 -- Start of processing for Designate_Next_Unit
3914
3915 begin
3916 if (K1 = N_Identifier or else
3917 K1 = N_Defining_Identifier)
3918 and then
3919 (K2 = N_Identifier or else
3920 K2 = N_Defining_Identifier)
3921 then
3922 return Chars (Name1) = Chars (Name2);
3923
3924 elsif
3925 (K1 = N_Expanded_Name or else
3926 K1 = N_Selected_Component or else
3927 K1 = N_Defining_Program_Unit_Name)
3928 and then
3929 (K2 = N_Expanded_Name or else
3930 K2 = N_Selected_Component or else
3931 K2 = N_Defining_Program_Unit_Name)
3932 then
3933 return
3934 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
3935 and then
3936 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
3937
3938 else
3939 return False;
3940 end if;
3941 end Designate_Same_Unit;
3942
3943 ------------------------------------------
3944 -- function Dynamic_Accessibility_Level --
3945 ------------------------------------------
3946
3947 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
3948 E : Entity_Id;
3949 Loc : constant Source_Ptr := Sloc (Expr);
3950
3951 function Make_Level_Literal (Level : Uint) return Node_Id;
3952 -- Construct an integer literal representing an accessibility level
3953 -- with its type set to Natural.
3954
3955 ------------------------
3956 -- Make_Level_Literal --
3957 ------------------------
3958
3959 function Make_Level_Literal (Level : Uint) return Node_Id is
3960 Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
3961 begin
3962 Set_Etype (Result, Standard_Natural);
3963 return Result;
3964 end Make_Level_Literal;
3965
3966 -- Start of processing for Dynamic_Accessibility_Level
3967
3968 begin
3969 if Is_Entity_Name (Expr) then
3970 E := Entity (Expr);
3971
3972 if Present (Renamed_Object (E)) then
3973 return Dynamic_Accessibility_Level (Renamed_Object (E));
3974 end if;
3975
3976 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
3977 if Present (Extra_Accessibility (E)) then
3978 return New_Occurrence_Of (Extra_Accessibility (E), Loc);
3979 end if;
3980 end if;
3981 end if;
3982
3983 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
3984
3985 case Nkind (Expr) is
3986
3987 -- For access discriminant, the level of the enclosing object
3988
3989 when N_Selected_Component =>
3990 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
3991 and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
3992 E_Anonymous_Access_Type
3993 then
3994 return Make_Level_Literal (Object_Access_Level (Expr));
3995 end if;
3996
3997 when N_Attribute_Reference =>
3998 case Get_Attribute_Id (Attribute_Name (Expr)) is
3999
4000 -- For X'Access, the level of the prefix X
4001
4002 when Attribute_Access =>
4003 return Make_Level_Literal
4004 (Object_Access_Level (Prefix (Expr)));
4005
4006 -- Treat the unchecked attributes as library-level
4007
4008 when Attribute_Unchecked_Access |
4009 Attribute_Unrestricted_Access =>
4010 return Make_Level_Literal (Scope_Depth (Standard_Standard));
4011
4012 -- No other access-valued attributes
4013
4014 when others =>
4015 raise Program_Error;
4016 end case;
4017
4018 when N_Allocator =>
4019
4020 -- Unimplemented: depends on context. As an actual parameter where
4021 -- formal type is anonymous, use
4022 -- Scope_Depth (Current_Scope) + 1.
4023 -- For other cases, see 3.10.2(14/3) and following. ???
4024
4025 null;
4026
4027 when N_Type_Conversion =>
4028 if not Is_Local_Anonymous_Access (Etype (Expr)) then
4029
4030 -- Handle type conversions introduced for a rename of an
4031 -- Ada 2012 stand-alone object of an anonymous access type.
4032
4033 return Dynamic_Accessibility_Level (Expression (Expr));
4034 end if;
4035
4036 when others =>
4037 null;
4038 end case;
4039
4040 return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
4041 end Dynamic_Accessibility_Level;
4042
4043 -----------------------------------
4044 -- Effective_Extra_Accessibility --
4045 -----------------------------------
4046
4047 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
4048 begin
4049 if Present (Renamed_Object (Id))
4050 and then Is_Entity_Name (Renamed_Object (Id))
4051 then
4052 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
4053 else
4054 return Extra_Accessibility (Id);
4055 end if;
4056 end Effective_Extra_Accessibility;
4057
4058 ------------------------------
4059 -- Enclosing_Comp_Unit_Node --
4060 ------------------------------
4061
4062 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
4063 Current_Node : Node_Id;
4064
4065 begin
4066 Current_Node := N;
4067 while Present (Current_Node)
4068 and then Nkind (Current_Node) /= N_Compilation_Unit
4069 loop
4070 Current_Node := Parent (Current_Node);
4071 end loop;
4072
4073 if Nkind (Current_Node) /= N_Compilation_Unit then
4074 return Empty;
4075 else
4076 return Current_Node;
4077 end if;
4078 end Enclosing_Comp_Unit_Node;
4079
4080 --------------------------
4081 -- Enclosing_CPP_Parent --
4082 --------------------------
4083
4084 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
4085 Parent_Typ : Entity_Id := Typ;
4086
4087 begin
4088 while not Is_CPP_Class (Parent_Typ)
4089 and then Etype (Parent_Typ) /= Parent_Typ
4090 loop
4091 Parent_Typ := Etype (Parent_Typ);
4092
4093 if Is_Private_Type (Parent_Typ) then
4094 Parent_Typ := Full_View (Base_Type (Parent_Typ));
4095 end if;
4096 end loop;
4097
4098 pragma Assert (Is_CPP_Class (Parent_Typ));
4099 return Parent_Typ;
4100 end Enclosing_CPP_Parent;
4101
4102 ----------------------------
4103 -- Enclosing_Generic_Body --
4104 ----------------------------
4105
4106 function Enclosing_Generic_Body
4107 (N : Node_Id) return Node_Id
4108 is
4109 P : Node_Id;
4110 Decl : Node_Id;
4111 Spec : Node_Id;
4112
4113 begin
4114 P := Parent (N);
4115 while Present (P) loop
4116 if Nkind (P) = N_Package_Body
4117 or else Nkind (P) = N_Subprogram_Body
4118 then
4119 Spec := Corresponding_Spec (P);
4120
4121 if Present (Spec) then
4122 Decl := Unit_Declaration_Node (Spec);
4123
4124 if Nkind (Decl) = N_Generic_Package_Declaration
4125 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
4126 then
4127 return P;
4128 end if;
4129 end if;
4130 end if;
4131
4132 P := Parent (P);
4133 end loop;
4134
4135 return Empty;
4136 end Enclosing_Generic_Body;
4137
4138 ----------------------------
4139 -- Enclosing_Generic_Unit --
4140 ----------------------------
4141
4142 function Enclosing_Generic_Unit
4143 (N : Node_Id) return Node_Id
4144 is
4145 P : Node_Id;
4146 Decl : Node_Id;
4147 Spec : Node_Id;
4148
4149 begin
4150 P := Parent (N);
4151 while Present (P) loop
4152 if Nkind (P) = N_Generic_Package_Declaration
4153 or else Nkind (P) = N_Generic_Subprogram_Declaration
4154 then
4155 return P;
4156
4157 elsif Nkind (P) = N_Package_Body
4158 or else Nkind (P) = N_Subprogram_Body
4159 then
4160 Spec := Corresponding_Spec (P);
4161
4162 if Present (Spec) then
4163 Decl := Unit_Declaration_Node (Spec);
4164
4165 if Nkind (Decl) = N_Generic_Package_Declaration
4166 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
4167 then
4168 return Decl;
4169 end if;
4170 end if;
4171 end if;
4172
4173 P := Parent (P);
4174 end loop;
4175
4176 return Empty;
4177 end Enclosing_Generic_Unit;
4178
4179 -------------------------------
4180 -- Enclosing_Lib_Unit_Entity --
4181 -------------------------------
4182
4183 function Enclosing_Lib_Unit_Entity
4184 (E : Entity_Id := Current_Scope) return Entity_Id
4185 is
4186 Unit_Entity : Entity_Id;
4187
4188 begin
4189 -- Look for enclosing library unit entity by following scope links.
4190 -- Equivalent to, but faster than indexing through the scope stack.
4191
4192 Unit_Entity := E;
4193 while (Present (Scope (Unit_Entity))
4194 and then Scope (Unit_Entity) /= Standard_Standard)
4195 and not Is_Child_Unit (Unit_Entity)
4196 loop
4197 Unit_Entity := Scope (Unit_Entity);
4198 end loop;
4199
4200 return Unit_Entity;
4201 end Enclosing_Lib_Unit_Entity;
4202
4203 -----------------------
4204 -- Enclosing_Package --
4205 -----------------------
4206
4207 function Enclosing_Package (E : Entity_Id) return Entity_Id is
4208 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
4209
4210 begin
4211 if Dynamic_Scope = Standard_Standard then
4212 return Standard_Standard;
4213
4214 elsif Dynamic_Scope = Empty then
4215 return Empty;
4216
4217 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
4218 E_Generic_Package)
4219 then
4220 return Dynamic_Scope;
4221
4222 else
4223 return Enclosing_Package (Dynamic_Scope);
4224 end if;
4225 end Enclosing_Package;
4226
4227 --------------------------
4228 -- Enclosing_Subprogram --
4229 --------------------------
4230
4231 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
4232 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
4233
4234 begin
4235 if Dynamic_Scope = Standard_Standard then
4236 return Empty;
4237
4238 elsif Dynamic_Scope = Empty then
4239 return Empty;
4240
4241 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
4242 return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
4243
4244 elsif Ekind (Dynamic_Scope) = E_Block
4245 or else Ekind (Dynamic_Scope) = E_Return_Statement
4246 then
4247 return Enclosing_Subprogram (Dynamic_Scope);
4248
4249 elsif Ekind (Dynamic_Scope) = E_Task_Type then
4250 return Get_Task_Body_Procedure (Dynamic_Scope);
4251
4252 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
4253 and then Present (Full_View (Dynamic_Scope))
4254 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
4255 then
4256 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
4257
4258 -- No body is generated if the protected operation is eliminated
4259
4260 elsif Convention (Dynamic_Scope) = Convention_Protected
4261 and then not Is_Eliminated (Dynamic_Scope)
4262 and then Present (Protected_Body_Subprogram (Dynamic_Scope))
4263 then
4264 return Protected_Body_Subprogram (Dynamic_Scope);
4265
4266 else
4267 return Dynamic_Scope;
4268 end if;
4269 end Enclosing_Subprogram;
4270
4271 ------------------------
4272 -- Ensure_Freeze_Node --
4273 ------------------------
4274
4275 procedure Ensure_Freeze_Node (E : Entity_Id) is
4276 FN : Node_Id;
4277
4278 begin
4279 if No (Freeze_Node (E)) then
4280 FN := Make_Freeze_Entity (Sloc (E));
4281 Set_Has_Delayed_Freeze (E);
4282 Set_Freeze_Node (E, FN);
4283 Set_Access_Types_To_Process (FN, No_Elist);
4284 Set_TSS_Elist (FN, No_Elist);
4285 Set_Entity (FN, E);
4286 end if;
4287 end Ensure_Freeze_Node;
4288
4289 ----------------
4290 -- Enter_Name --
4291 ----------------
4292
4293 procedure Enter_Name (Def_Id : Entity_Id) is
4294 C : constant Entity_Id := Current_Entity (Def_Id);
4295 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
4296 S : constant Entity_Id := Current_Scope;
4297
4298 begin
4299 Generate_Definition (Def_Id);
4300
4301 -- Add new name to current scope declarations. Check for duplicate
4302 -- declaration, which may or may not be a genuine error.
4303
4304 if Present (E) then
4305
4306 -- Case of previous entity entered because of a missing declaration
4307 -- or else a bad subtype indication. Best is to use the new entity,
4308 -- and make the previous one invisible.
4309
4310 if Etype (E) = Any_Type then
4311 Set_Is_Immediately_Visible (E, False);
4312
4313 -- Case of renaming declaration constructed for package instances.
4314 -- if there is an explicit declaration with the same identifier,
4315 -- the renaming is not immediately visible any longer, but remains
4316 -- visible through selected component notation.
4317
4318 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
4319 and then not Comes_From_Source (E)
4320 then
4321 Set_Is_Immediately_Visible (E, False);
4322
4323 -- The new entity may be the package renaming, which has the same
4324 -- same name as a generic formal which has been seen already.
4325
4326 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
4327 and then not Comes_From_Source (Def_Id)
4328 then
4329 Set_Is_Immediately_Visible (E, False);
4330
4331 -- For a fat pointer corresponding to a remote access to subprogram,
4332 -- we use the same identifier as the RAS type, so that the proper
4333 -- name appears in the stub. This type is only retrieved through
4334 -- the RAS type and never by visibility, and is not added to the
4335 -- visibility list (see below).
4336
4337 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
4338 and then Present (Corresponding_Remote_Type (Def_Id))
4339 then
4340 null;
4341
4342 -- Case of an implicit operation or derived literal. The new entity
4343 -- hides the implicit one, which is removed from all visibility,
4344 -- i.e. the entity list of its scope, and homonym chain of its name.
4345
4346 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
4347 or else Is_Internal (E)
4348 then
4349 declare
4350 Prev : Entity_Id;
4351 Prev_Vis : Entity_Id;
4352 Decl : constant Node_Id := Parent (E);
4353
4354 begin
4355 -- If E is an implicit declaration, it cannot be the first
4356 -- entity in the scope.
4357
4358 Prev := First_Entity (Current_Scope);
4359 while Present (Prev)
4360 and then Next_Entity (Prev) /= E
4361 loop
4362 Next_Entity (Prev);
4363 end loop;
4364
4365 if No (Prev) then
4366
4367 -- If E is not on the entity chain of the current scope,
4368 -- it is an implicit declaration in the generic formal
4369 -- part of a generic subprogram. When analyzing the body,
4370 -- the generic formals are visible but not on the entity
4371 -- chain of the subprogram. The new entity will become
4372 -- the visible one in the body.
4373
4374 pragma Assert
4375 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
4376 null;
4377
4378 else
4379 Set_Next_Entity (Prev, Next_Entity (E));
4380
4381 if No (Next_Entity (Prev)) then
4382 Set_Last_Entity (Current_Scope, Prev);
4383 end if;
4384
4385 if E = Current_Entity (E) then
4386 Prev_Vis := Empty;
4387
4388 else
4389 Prev_Vis := Current_Entity (E);
4390 while Homonym (Prev_Vis) /= E loop
4391 Prev_Vis := Homonym (Prev_Vis);
4392 end loop;
4393 end if;
4394
4395 if Present (Prev_Vis) then
4396
4397 -- Skip E in the visibility chain
4398
4399 Set_Homonym (Prev_Vis, Homonym (E));
4400
4401 else
4402 Set_Name_Entity_Id (Chars (E), Homonym (E));
4403 end if;
4404 end if;
4405 end;
4406
4407 -- This section of code could use a comment ???
4408
4409 elsif Present (Etype (E))
4410 and then Is_Concurrent_Type (Etype (E))
4411 and then E = Def_Id
4412 then
4413 return;
4414
4415 -- If the homograph is a protected component renaming, it should not
4416 -- be hiding the current entity. Such renamings are treated as weak
4417 -- declarations.
4418
4419 elsif Is_Prival (E) then
4420 Set_Is_Immediately_Visible (E, False);
4421
4422 -- In this case the current entity is a protected component renaming.
4423 -- Perform minimal decoration by setting the scope and return since
4424 -- the prival should not be hiding other visible entities.
4425
4426 elsif Is_Prival (Def_Id) then
4427 Set_Scope (Def_Id, Current_Scope);
4428 return;
4429
4430 -- Analogous to privals, the discriminal generated for an entry index
4431 -- parameter acts as a weak declaration. Perform minimal decoration
4432 -- to avoid bogus errors.
4433
4434 elsif Is_Discriminal (Def_Id)
4435 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
4436 then
4437 Set_Scope (Def_Id, Current_Scope);
4438 return;
4439
4440 -- In the body or private part of an instance, a type extension may
4441 -- introduce a component with the same name as that of an actual. The
4442 -- legality rule is not enforced, but the semantics of the full type
4443 -- with two components of same name are not clear at this point???
4444
4445 elsif In_Instance_Not_Visible then
4446 null;
4447
4448 -- When compiling a package body, some child units may have become
4449 -- visible. They cannot conflict with local entities that hide them.
4450
4451 elsif Is_Child_Unit (E)
4452 and then In_Open_Scopes (Scope (E))
4453 and then not Is_Immediately_Visible (E)
4454 then
4455 null;
4456
4457 -- Conversely, with front-end inlining we may compile the parent body
4458 -- first, and a child unit subsequently. The context is now the
4459 -- parent spec, and body entities are not visible.
4460
4461 elsif Is_Child_Unit (Def_Id)
4462 and then Is_Package_Body_Entity (E)
4463 and then not In_Package_Body (Current_Scope)
4464 then
4465 null;
4466
4467 -- Case of genuine duplicate declaration
4468
4469 else
4470 Error_Msg_Sloc := Sloc (E);
4471
4472 -- If the previous declaration is an incomplete type declaration
4473 -- this may be an attempt to complete it with a private type. The
4474 -- following avoids confusing cascaded errors.
4475
4476 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
4477 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
4478 then
4479 Error_Msg_N
4480 ("incomplete type cannot be completed with a private " &
4481 "declaration", Parent (Def_Id));
4482 Set_Is_Immediately_Visible (E, False);
4483 Set_Full_View (E, Def_Id);
4484
4485 -- An inherited component of a record conflicts with a new
4486 -- discriminant. The discriminant is inserted first in the scope,
4487 -- but the error should be posted on it, not on the component.
4488
4489 elsif Ekind (E) = E_Discriminant
4490 and then Present (Scope (Def_Id))
4491 and then Scope (Def_Id) /= Current_Scope
4492 then
4493 Error_Msg_Sloc := Sloc (Def_Id);
4494 Error_Msg_N ("& conflicts with declaration#", E);
4495 return;
4496
4497 -- If the name of the unit appears in its own context clause, a
4498 -- dummy package with the name has already been created, and the
4499 -- error emitted. Try to continue quietly.
4500
4501 elsif Error_Posted (E)
4502 and then Sloc (E) = No_Location
4503 and then Nkind (Parent (E)) = N_Package_Specification
4504 and then Current_Scope = Standard_Standard
4505 then
4506 Set_Scope (Def_Id, Current_Scope);
4507 return;
4508
4509 else
4510 Error_Msg_N ("& conflicts with declaration#", Def_Id);
4511
4512 -- Avoid cascaded messages with duplicate components in
4513 -- derived types.
4514
4515 if Ekind_In (E, E_Component, E_Discriminant) then
4516 return;
4517 end if;
4518 end if;
4519
4520 if Nkind (Parent (Parent (Def_Id))) =
4521 N_Generic_Subprogram_Declaration
4522 and then Def_Id =
4523 Defining_Entity (Specification (Parent (Parent (Def_Id))))
4524 then
4525 Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
4526 end if;
4527
4528 -- If entity is in standard, then we are in trouble, because it
4529 -- means that we have a library package with a duplicated name.
4530 -- That's hard to recover from, so abort!
4531
4532 if S = Standard_Standard then
4533 raise Unrecoverable_Error;
4534
4535 -- Otherwise we continue with the declaration. Having two
4536 -- identical declarations should not cause us too much trouble!
4537
4538 else
4539 null;
4540 end if;
4541 end if;
4542 end if;
4543
4544 -- If we fall through, declaration is OK, at least OK enough to continue
4545
4546 -- If Def_Id is a discriminant or a record component we are in the midst
4547 -- of inheriting components in a derived record definition. Preserve
4548 -- their Ekind and Etype.
4549
4550 if Ekind_In (Def_Id, E_Discriminant, E_Component) then
4551 null;
4552
4553 -- If a type is already set, leave it alone (happens when a type
4554 -- declaration is reanalyzed following a call to the optimizer).
4555
4556 elsif Present (Etype (Def_Id)) then
4557 null;
4558
4559 -- Otherwise, the kind E_Void insures that premature uses of the entity
4560 -- will be detected. Any_Type insures that no cascaded errors will occur
4561
4562 else
4563 Set_Ekind (Def_Id, E_Void);
4564 Set_Etype (Def_Id, Any_Type);
4565 end if;
4566
4567 -- Inherited discriminants and components in derived record types are
4568 -- immediately visible. Itypes are not.
4569
4570 if Ekind_In (Def_Id, E_Discriminant, E_Component)
4571 or else (No (Corresponding_Remote_Type (Def_Id))
4572 and then not Is_Itype (Def_Id))
4573 then
4574 Set_Is_Immediately_Visible (Def_Id);
4575 Set_Current_Entity (Def_Id);
4576 end if;
4577
4578 Set_Homonym (Def_Id, C);
4579 Append_Entity (Def_Id, S);
4580 Set_Public_Status (Def_Id);
4581
4582 -- Declaring a homonym is not allowed in SPARK ...
4583
4584 if Present (C)
4585 and then Restriction_Check_Required (SPARK_05)
4586 then
4587 declare
4588 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
4589 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
4590 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C);
4591
4592 begin
4593 -- ... unless the new declaration is in a subprogram, and the
4594 -- visible declaration is a variable declaration or a parameter
4595 -- specification outside that subprogram.
4596
4597 if Present (Enclosing_Subp)
4598 and then Nkind_In (Parent (C), N_Object_Declaration,
4599 N_Parameter_Specification)
4600 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
4601 then
4602 null;
4603
4604 -- ... or the new declaration is in a package, and the visible
4605 -- declaration occurs outside that package.
4606
4607 elsif Present (Enclosing_Pack)
4608 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
4609 then
4610 null;
4611
4612 -- ... or the new declaration is a component declaration in a
4613 -- record type definition.
4614
4615 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
4616 null;
4617
4618 -- Don't issue error for non-source entities
4619
4620 elsif Comes_From_Source (Def_Id)
4621 and then Comes_From_Source (C)
4622 then
4623 Error_Msg_Sloc := Sloc (C);
4624 Check_SPARK_Restriction
4625 ("redeclaration of identifier &#", Def_Id);
4626 end if;
4627 end;
4628 end if;
4629
4630 -- Warn if new entity hides an old one
4631
4632 if Warn_On_Hiding and then Present (C)
4633
4634 -- Don't warn for record components since they always have a well
4635 -- defined scope which does not confuse other uses. Note that in
4636 -- some cases, Ekind has not been set yet.
4637
4638 and then Ekind (C) /= E_Component
4639 and then Ekind (C) /= E_Discriminant
4640 and then Nkind (Parent (C)) /= N_Component_Declaration
4641 and then Ekind (Def_Id) /= E_Component
4642 and then Ekind (Def_Id) /= E_Discriminant
4643 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
4644
4645 -- Don't warn for one character variables. It is too common to use
4646 -- such variables as locals and will just cause too many false hits.
4647
4648 and then Length_Of_Name (Chars (C)) /= 1
4649
4650 -- Don't warn for non-source entities
4651
4652 and then Comes_From_Source (C)
4653 and then Comes_From_Source (Def_Id)
4654
4655 -- Don't warn unless entity in question is in extended main source
4656
4657 and then In_Extended_Main_Source_Unit (Def_Id)
4658
4659 -- Finally, the hidden entity must be either immediately visible or
4660 -- use visible (i.e. from a used package).
4661
4662 and then
4663 (Is_Immediately_Visible (C)
4664 or else
4665 Is_Potentially_Use_Visible (C))
4666 then
4667 Error_Msg_Sloc := Sloc (C);
4668 Error_Msg_N ("declaration hides &#?h?", Def_Id);
4669 end if;
4670 end Enter_Name;
4671
4672 --------------------------
4673 -- Explain_Limited_Type --
4674 --------------------------
4675
4676 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
4677 C : Entity_Id;
4678
4679 begin
4680 -- For array, component type must be limited
4681
4682 if Is_Array_Type (T) then
4683 Error_Msg_Node_2 := T;
4684 Error_Msg_NE
4685 ("\component type& of type& is limited", N, Component_Type (T));
4686 Explain_Limited_Type (Component_Type (T), N);
4687
4688 elsif Is_Record_Type (T) then
4689
4690 -- No need for extra messages if explicit limited record
4691
4692 if Is_Limited_Record (Base_Type (T)) then
4693 return;
4694 end if;
4695
4696 -- Otherwise find a limited component. Check only components that
4697 -- come from source, or inherited components that appear in the
4698 -- source of the ancestor.
4699
4700 C := First_Component (T);
4701 while Present (C) loop
4702 if Is_Limited_Type (Etype (C))
4703 and then
4704 (Comes_From_Source (C)
4705 or else
4706 (Present (Original_Record_Component (C))
4707 and then
4708 Comes_From_Source (Original_Record_Component (C))))
4709 then
4710 Error_Msg_Node_2 := T;
4711 Error_Msg_NE ("\component& of type& has limited type", N, C);
4712 Explain_Limited_Type (Etype (C), N);
4713 return;
4714 end if;
4715
4716 Next_Component (C);
4717 end loop;
4718
4719 -- The type may be declared explicitly limited, even if no component
4720 -- of it is limited, in which case we fall out of the loop.
4721 return;
4722 end if;
4723 end Explain_Limited_Type;
4724
4725 -----------------
4726 -- Find_Actual --
4727 -----------------
4728
4729 procedure Find_Actual
4730 (N : Node_Id;
4731 Formal : out Entity_Id;
4732 Call : out Node_Id)
4733 is
4734 Parnt : constant Node_Id := Parent (N);
4735 Actual : Node_Id;
4736
4737 begin
4738 if (Nkind (Parnt) = N_Indexed_Component
4739 or else
4740 Nkind (Parnt) = N_Selected_Component)
4741 and then N = Prefix (Parnt)
4742 then
4743 Find_Actual (Parnt, Formal, Call);
4744 return;
4745
4746 elsif Nkind (Parnt) = N_Parameter_Association
4747 and then N = Explicit_Actual_Parameter (Parnt)
4748 then
4749 Call := Parent (Parnt);
4750
4751 elsif Nkind (Parnt) in N_Subprogram_Call then
4752 Call := Parnt;
4753
4754 else
4755 Formal := Empty;
4756 Call := Empty;
4757 return;
4758 end if;
4759
4760 -- If we have a call to a subprogram look for the parameter. Note that
4761 -- we exclude overloaded calls, since we don't know enough to be sure
4762 -- of giving the right answer in this case.
4763
4764 if Is_Entity_Name (Name (Call))
4765 and then Present (Entity (Name (Call)))
4766 and then Is_Overloadable (Entity (Name (Call)))
4767 and then not Is_Overloaded (Name (Call))
4768 then
4769 -- Fall here if we are definitely a parameter
4770
4771 Actual := First_Actual (Call);
4772 Formal := First_Formal (Entity (Name (Call)));
4773 while Present (Formal) and then Present (Actual) loop
4774 if Actual = N then
4775 return;
4776 else
4777 Actual := Next_Actual (Actual);
4778 Formal := Next_Formal (Formal);
4779 end if;
4780 end loop;
4781 end if;
4782
4783 -- Fall through here if we did not find matching actual
4784
4785 Formal := Empty;
4786 Call := Empty;
4787 end Find_Actual;
4788
4789 ---------------------------
4790 -- Find_Body_Discriminal --
4791 ---------------------------
4792
4793 function Find_Body_Discriminal
4794 (Spec_Discriminant : Entity_Id) return Entity_Id
4795 is
4796 Tsk : Entity_Id;
4797 Disc : Entity_Id;
4798
4799 begin
4800 -- If expansion is suppressed, then the scope can be the concurrent type
4801 -- itself rather than a corresponding concurrent record type.
4802
4803 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
4804 Tsk := Scope (Spec_Discriminant);
4805
4806 else
4807 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
4808
4809 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
4810 end if;
4811
4812 -- Find discriminant of original concurrent type, and use its current
4813 -- discriminal, which is the renaming within the task/protected body.
4814
4815 Disc := First_Discriminant (Tsk);
4816 while Present (Disc) loop
4817 if Chars (Disc) = Chars (Spec_Discriminant) then
4818 return Discriminal (Disc);
4819 end if;
4820
4821 Next_Discriminant (Disc);
4822 end loop;
4823
4824 -- That loop should always succeed in finding a matching entry and
4825 -- returning. Fatal error if not.
4826
4827 raise Program_Error;
4828 end Find_Body_Discriminal;
4829
4830 -------------------------------------
4831 -- Find_Corresponding_Discriminant --
4832 -------------------------------------
4833
4834 function Find_Corresponding_Discriminant
4835 (Id : Node_Id;
4836 Typ : Entity_Id) return Entity_Id
4837 is
4838 Par_Disc : Entity_Id;
4839 Old_Disc : Entity_Id;
4840 New_Disc : Entity_Id;
4841
4842 begin
4843 Par_Disc := Original_Record_Component (Original_Discriminant (Id));
4844
4845 -- The original type may currently be private, and the discriminant
4846 -- only appear on its full view.
4847
4848 if Is_Private_Type (Scope (Par_Disc))
4849 and then not Has_Discriminants (Scope (Par_Disc))
4850 and then Present (Full_View (Scope (Par_Disc)))
4851 then
4852 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
4853 else
4854 Old_Disc := First_Discriminant (Scope (Par_Disc));
4855 end if;
4856
4857 if Is_Class_Wide_Type (Typ) then
4858 New_Disc := First_Discriminant (Root_Type (Typ));
4859 else
4860 New_Disc := First_Discriminant (Typ);
4861 end if;
4862
4863 while Present (Old_Disc) and then Present (New_Disc) loop
4864 if Old_Disc = Par_Disc then
4865 return New_Disc;
4866 else
4867 Next_Discriminant (Old_Disc);
4868 Next_Discriminant (New_Disc);
4869 end if;
4870 end loop;
4871
4872 -- Should always find it
4873
4874 raise Program_Error;
4875 end Find_Corresponding_Discriminant;
4876
4877 ------------------------------------
4878 -- Find_Loop_In_Conditional_Block --
4879 ------------------------------------
4880
4881 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is
4882 Stmt : Node_Id;
4883
4884 begin
4885 Stmt := N;
4886
4887 if Nkind (Stmt) = N_If_Statement then
4888 Stmt := First (Then_Statements (Stmt));
4889 end if;
4890
4891 pragma Assert (Nkind (Stmt) = N_Block_Statement);
4892
4893 -- Inspect the statements of the conditional block. In general the loop
4894 -- should be the first statement in the statement sequence of the block,
4895 -- but the finalization machinery may have introduced extra object
4896 -- declarations.
4897
4898 Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
4899 while Present (Stmt) loop
4900 if Nkind (Stmt) = N_Loop_Statement then
4901 return Stmt;
4902 end if;
4903
4904 Next (Stmt);
4905 end loop;
4906
4907 -- The expansion of attribute 'Loop_Entry produced a malformed block
4908
4909 raise Program_Error;
4910 end Find_Loop_In_Conditional_Block;
4911
4912 --------------------------
4913 -- Find_Overlaid_Entity --
4914 --------------------------
4915
4916 procedure Find_Overlaid_Entity
4917 (N : Node_Id;
4918 Ent : out Entity_Id;
4919 Off : out Boolean)
4920 is
4921 Expr : Node_Id;
4922
4923 begin
4924 -- We are looking for one of the two following forms:
4925
4926 -- for X'Address use Y'Address
4927
4928 -- or
4929
4930 -- Const : constant Address := expr;
4931 -- ...
4932 -- for X'Address use Const;
4933
4934 -- In the second case, the expr is either Y'Address, or recursively a
4935 -- constant that eventually references Y'Address.
4936
4937 Ent := Empty;
4938 Off := False;
4939
4940 if Nkind (N) = N_Attribute_Definition_Clause
4941 and then Chars (N) = Name_Address
4942 then
4943 Expr := Expression (N);
4944
4945 -- This loop checks the form of the expression for Y'Address,
4946 -- using recursion to deal with intermediate constants.
4947
4948 loop
4949 -- Check for Y'Address
4950
4951 if Nkind (Expr) = N_Attribute_Reference
4952 and then Attribute_Name (Expr) = Name_Address
4953 then
4954 Expr := Prefix (Expr);
4955 exit;
4956
4957 -- Check for Const where Const is a constant entity
4958
4959 elsif Is_Entity_Name (Expr)
4960 and then Ekind (Entity (Expr)) = E_Constant
4961 then
4962 Expr := Constant_Value (Entity (Expr));
4963
4964 -- Anything else does not need checking
4965
4966 else
4967 return;
4968 end if;
4969 end loop;
4970
4971 -- This loop checks the form of the prefix for an entity, using
4972 -- recursion to deal with intermediate components.
4973
4974 loop
4975 -- Check for Y where Y is an entity
4976
4977 if Is_Entity_Name (Expr) then
4978 Ent := Entity (Expr);
4979 return;
4980
4981 -- Check for components
4982
4983 elsif
4984 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
4985 then
4986 Expr := Prefix (Expr);
4987 Off := True;
4988
4989 -- Anything else does not need checking
4990
4991 else
4992 return;
4993 end if;
4994 end loop;
4995 end if;
4996 end Find_Overlaid_Entity;
4997
4998 -------------------------
4999 -- Find_Parameter_Type --
5000 -------------------------
5001
5002 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
5003 begin
5004 if Nkind (Param) /= N_Parameter_Specification then
5005 return Empty;
5006
5007 -- For an access parameter, obtain the type from the formal entity
5008 -- itself, because access to subprogram nodes do not carry a type.
5009 -- Shouldn't we always use the formal entity ???
5010
5011 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
5012 return Etype (Defining_Identifier (Param));
5013
5014 else
5015 return Etype (Parameter_Type (Param));
5016 end if;
5017 end Find_Parameter_Type;
5018
5019 -----------------------------
5020 -- Find_Static_Alternative --
5021 -----------------------------
5022
5023 function Find_Static_Alternative (N : Node_Id) return Node_Id is
5024 Expr : constant Node_Id := Expression (N);
5025 Val : constant Uint := Expr_Value (Expr);
5026 Alt : Node_Id;
5027 Choice : Node_Id;
5028
5029 begin
5030 Alt := First (Alternatives (N));
5031
5032 Search : loop
5033 if Nkind (Alt) /= N_Pragma then
5034 Choice := First (Discrete_Choices (Alt));
5035 while Present (Choice) loop
5036
5037 -- Others choice, always matches
5038
5039 if Nkind (Choice) = N_Others_Choice then
5040 exit Search;
5041
5042 -- Range, check if value is in the range
5043
5044 elsif Nkind (Choice) = N_Range then
5045 exit Search when
5046 Val >= Expr_Value (Low_Bound (Choice))
5047 and then
5048 Val <= Expr_Value (High_Bound (Choice));
5049
5050 -- Choice is a subtype name. Note that we know it must
5051 -- be a static subtype, since otherwise it would have
5052 -- been diagnosed as illegal.
5053
5054 elsif Is_Entity_Name (Choice)
5055 and then Is_Type (Entity (Choice))
5056 then
5057 exit Search when Is_In_Range (Expr, Etype (Choice),
5058 Assume_Valid => False);
5059
5060 -- Choice is a subtype indication
5061
5062 elsif Nkind (Choice) = N_Subtype_Indication then
5063 declare
5064 C : constant Node_Id := Constraint (Choice);
5065 R : constant Node_Id := Range_Expression (C);
5066
5067 begin
5068 exit Search when
5069 Val >= Expr_Value (Low_Bound (R))
5070 and then
5071 Val <= Expr_Value (High_Bound (R));
5072 end;
5073
5074 -- Choice is a simple expression
5075
5076 else
5077 exit Search when Val = Expr_Value (Choice);
5078 end if;
5079
5080 Next (Choice);
5081 end loop;
5082 end if;
5083
5084 Next (Alt);
5085 pragma Assert (Present (Alt));
5086 end loop Search;
5087
5088 -- The above loop *must* terminate by finding a match, since
5089 -- we know the case statement is valid, and the value of the
5090 -- expression is known at compile time. When we fall out of
5091 -- the loop, Alt points to the alternative that we know will
5092 -- be selected at run time.
5093
5094 return Alt;
5095 end Find_Static_Alternative;
5096
5097 ------------------
5098 -- First_Actual --
5099 ------------------
5100
5101 function First_Actual (Node : Node_Id) return Node_Id is
5102 N : Node_Id;
5103
5104 begin
5105 if No (Parameter_Associations (Node)) then
5106 return Empty;
5107 end if;
5108
5109 N := First (Parameter_Associations (Node));
5110
5111 if Nkind (N) = N_Parameter_Association then
5112 return First_Named_Actual (Node);
5113 else
5114 return N;
5115 end if;
5116 end First_Actual;
5117
5118 -----------------------
5119 -- Gather_Components --
5120 -----------------------
5121
5122 procedure Gather_Components
5123 (Typ : Entity_Id;
5124 Comp_List : Node_Id;
5125 Governed_By : List_Id;
5126 Into : Elist_Id;
5127 Report_Errors : out Boolean)
5128 is
5129 Assoc : Node_Id;
5130 Variant : Node_Id;
5131 Discrete_Choice : Node_Id;
5132 Comp_Item : Node_Id;
5133
5134 Discrim : Entity_Id;
5135 Discrim_Name : Node_Id;
5136 Discrim_Value : Node_Id;
5137
5138 begin
5139 Report_Errors := False;
5140
5141 if No (Comp_List) or else Null_Present (Comp_List) then
5142 return;
5143
5144 elsif Present (Component_Items (Comp_List)) then
5145 Comp_Item := First (Component_Items (Comp_List));
5146
5147 else
5148 Comp_Item := Empty;
5149 end if;
5150
5151 while Present (Comp_Item) loop
5152
5153 -- Skip the tag of a tagged record, the interface tags, as well
5154 -- as all items that are not user components (anonymous types,
5155 -- rep clauses, Parent field, controller field).
5156
5157 if Nkind (Comp_Item) = N_Component_Declaration then
5158 declare
5159 Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
5160 begin
5161 if not Is_Tag (Comp)
5162 and then Chars (Comp) /= Name_uParent
5163 then
5164 Append_Elmt (Comp, Into);
5165 end if;
5166 end;
5167 end if;
5168
5169 Next (Comp_Item);
5170 end loop;
5171
5172 if No (Variant_Part (Comp_List)) then
5173 return;
5174 else
5175 Discrim_Name := Name (Variant_Part (Comp_List));
5176 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
5177 end if;
5178
5179 -- Look for the discriminant that governs this variant part.
5180 -- The discriminant *must* be in the Governed_By List
5181
5182 Assoc := First (Governed_By);
5183 Find_Constraint : loop
5184 Discrim := First (Choices (Assoc));
5185 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
5186 or else (Present (Corresponding_Discriminant (Entity (Discrim)))
5187 and then
5188 Chars (Corresponding_Discriminant (Entity (Discrim)))
5189 = Chars (Discrim_Name))
5190 or else Chars (Original_Record_Component (Entity (Discrim)))
5191 = Chars (Discrim_Name);
5192
5193 if No (Next (Assoc)) then
5194 if not Is_Constrained (Typ)
5195 and then Is_Derived_Type (Typ)
5196 and then Present (Stored_Constraint (Typ))
5197 then
5198 -- If the type is a tagged type with inherited discriminants,
5199 -- use the stored constraint on the parent in order to find
5200 -- the values of discriminants that are otherwise hidden by an
5201 -- explicit constraint. Renamed discriminants are handled in
5202 -- the code above.
5203
5204 -- If several parent discriminants are renamed by a single
5205 -- discriminant of the derived type, the call to obtain the
5206 -- Corresponding_Discriminant field only retrieves the last
5207 -- of them. We recover the constraint on the others from the
5208 -- Stored_Constraint as well.
5209
5210 declare
5211 D : Entity_Id;
5212 C : Elmt_Id;
5213
5214 begin
5215 D := First_Discriminant (Etype (Typ));
5216 C := First_Elmt (Stored_Constraint (Typ));
5217 while Present (D) and then Present (C) loop
5218 if Chars (Discrim_Name) = Chars (D) then
5219 if Is_Entity_Name (Node (C))
5220 and then Entity (Node (C)) = Entity (Discrim)
5221 then
5222 -- D is renamed by Discrim, whose value is given in
5223 -- Assoc.
5224
5225 null;
5226
5227 else
5228 Assoc :=
5229 Make_Component_Association (Sloc (Typ),
5230 New_List
5231 (New_Occurrence_Of (D, Sloc (Typ))),
5232 Duplicate_Subexpr_No_Checks (Node (C)));
5233 end if;
5234 exit Find_Constraint;
5235 end if;
5236
5237 Next_Discriminant (D);
5238 Next_Elmt (C);
5239 end loop;
5240 end;
5241 end if;
5242 end if;
5243
5244 if No (Next (Assoc)) then
5245 Error_Msg_NE (" missing value for discriminant&",
5246 First (Governed_By), Discrim_Name);
5247 Report_Errors := True;
5248 return;
5249 end if;
5250
5251 Next (Assoc);
5252 end loop Find_Constraint;
5253
5254 Discrim_Value := Expression (Assoc);
5255
5256 if not Is_OK_Static_Expression (Discrim_Value) then
5257 Error_Msg_FE
5258 ("value for discriminant & must be static!",
5259 Discrim_Value, Discrim);
5260 Why_Not_Static (Discrim_Value);
5261 Report_Errors := True;
5262 return;
5263 end if;
5264
5265 Search_For_Discriminant_Value : declare
5266 Low : Node_Id;
5267 High : Node_Id;
5268
5269 UI_High : Uint;
5270 UI_Low : Uint;
5271 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
5272
5273 begin
5274 Find_Discrete_Value : while Present (Variant) loop
5275 Discrete_Choice := First (Discrete_Choices (Variant));
5276 while Present (Discrete_Choice) loop
5277
5278 exit Find_Discrete_Value when
5279 Nkind (Discrete_Choice) = N_Others_Choice;
5280
5281 Get_Index_Bounds (Discrete_Choice, Low, High);
5282
5283 UI_Low := Expr_Value (Low);
5284 UI_High := Expr_Value (High);
5285
5286 exit Find_Discrete_Value when
5287 UI_Low <= UI_Discrim_Value
5288 and then
5289 UI_High >= UI_Discrim_Value;
5290
5291 Next (Discrete_Choice);
5292 end loop;
5293
5294 Next_Non_Pragma (Variant);
5295 end loop Find_Discrete_Value;
5296 end Search_For_Discriminant_Value;
5297
5298 if No (Variant) then
5299 Error_Msg_NE
5300 ("value of discriminant & is out of range", Discrim_Value, Discrim);
5301 Report_Errors := True;
5302 return;
5303 end if;
5304
5305 -- If we have found the corresponding choice, recursively add its
5306 -- components to the Into list.
5307
5308 Gather_Components (Empty,
5309 Component_List (Variant), Governed_By, Into, Report_Errors);
5310 end Gather_Components;
5311
5312 ------------------------
5313 -- Get_Actual_Subtype --
5314 ------------------------
5315
5316 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
5317 Typ : constant Entity_Id := Etype (N);
5318 Utyp : Entity_Id := Underlying_Type (Typ);
5319 Decl : Node_Id;
5320 Atyp : Entity_Id;
5321
5322 begin
5323 if No (Utyp) then
5324 Utyp := Typ;
5325 end if;
5326
5327 -- If what we have is an identifier that references a subprogram
5328 -- formal, or a variable or constant object, then we get the actual
5329 -- subtype from the referenced entity if one has been built.
5330
5331 if Nkind (N) = N_Identifier
5332 and then
5333 (Is_Formal (Entity (N))
5334 or else Ekind (Entity (N)) = E_Constant
5335 or else Ekind (Entity (N)) = E_Variable)
5336 and then Present (Actual_Subtype (Entity (N)))
5337 then
5338 return Actual_Subtype (Entity (N));
5339
5340 -- Actual subtype of unchecked union is always itself. We never need
5341 -- the "real" actual subtype. If we did, we couldn't get it anyway
5342 -- because the discriminant is not available. The restrictions on
5343 -- Unchecked_Union are designed to make sure that this is OK.
5344
5345 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
5346 return Typ;
5347
5348 -- Here for the unconstrained case, we must find actual subtype
5349 -- No actual subtype is available, so we must build it on the fly.
5350
5351 -- Checking the type, not the underlying type, for constrainedness
5352 -- seems to be necessary. Maybe all the tests should be on the type???
5353
5354 elsif (not Is_Constrained (Typ))
5355 and then (Is_Array_Type (Utyp)
5356 or else (Is_Record_Type (Utyp)
5357 and then Has_Discriminants (Utyp)))
5358 and then not Has_Unknown_Discriminants (Utyp)
5359 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
5360 then
5361 -- Nothing to do if in spec expression (why not???)
5362
5363 if In_Spec_Expression then
5364 return Typ;
5365
5366 elsif Is_Private_Type (Typ)
5367 and then not Has_Discriminants (Typ)
5368 then
5369 -- If the type has no discriminants, there is no subtype to
5370 -- build, even if the underlying type is discriminated.
5371
5372 return Typ;
5373
5374 -- Else build the actual subtype
5375
5376 else
5377 Decl := Build_Actual_Subtype (Typ, N);
5378 Atyp := Defining_Identifier (Decl);
5379
5380 -- If Build_Actual_Subtype generated a new declaration then use it
5381
5382 if Atyp /= Typ then
5383
5384 -- The actual subtype is an Itype, so analyze the declaration,
5385 -- but do not attach it to the tree, to get the type defined.
5386
5387 Set_Parent (Decl, N);
5388 Set_Is_Itype (Atyp);
5389 Analyze (Decl, Suppress => All_Checks);
5390 Set_Associated_Node_For_Itype (Atyp, N);
5391 Set_Has_Delayed_Freeze (Atyp, False);
5392
5393 -- We need to freeze the actual subtype immediately. This is
5394 -- needed, because otherwise this Itype will not get frozen
5395 -- at all, and it is always safe to freeze on creation because
5396 -- any associated types must be frozen at this point.
5397
5398 Freeze_Itype (Atyp, N);
5399 return Atyp;
5400
5401 -- Otherwise we did not build a declaration, so return original
5402
5403 else
5404 return Typ;
5405 end if;
5406 end if;
5407
5408 -- For all remaining cases, the actual subtype is the same as
5409 -- the nominal type.
5410
5411 else
5412 return Typ;
5413 end if;
5414 end Get_Actual_Subtype;
5415
5416 -------------------------------------
5417 -- Get_Actual_Subtype_If_Available --
5418 -------------------------------------
5419
5420 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
5421 Typ : constant Entity_Id := Etype (N);
5422
5423 begin
5424 -- If what we have is an identifier that references a subprogram
5425 -- formal, or a variable or constant object, then we get the actual
5426 -- subtype from the referenced entity if one has been built.
5427
5428 if Nkind (N) = N_Identifier
5429 and then
5430 (Is_Formal (Entity (N))
5431 or else Ekind (Entity (N)) = E_Constant
5432 or else Ekind (Entity (N)) = E_Variable)
5433 and then Present (Actual_Subtype (Entity (N)))
5434 then
5435 return Actual_Subtype (Entity (N));
5436
5437 -- Otherwise the Etype of N is returned unchanged
5438
5439 else
5440 return Typ;
5441 end if;
5442 end Get_Actual_Subtype_If_Available;
5443
5444 ------------------------
5445 -- Get_Body_From_Stub --
5446 ------------------------
5447
5448 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
5449 begin
5450 return Proper_Body (Unit (Library_Unit (N)));
5451 end Get_Body_From_Stub;
5452
5453 -------------------------------
5454 -- Get_Default_External_Name --
5455 -------------------------------
5456
5457 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
5458 begin
5459 Get_Decoded_Name_String (Chars (E));
5460
5461 if Opt.External_Name_Imp_Casing = Uppercase then
5462 Set_Casing (All_Upper_Case);
5463 else
5464 Set_Casing (All_Lower_Case);
5465 end if;
5466
5467 return
5468 Make_String_Literal (Sloc (E),
5469 Strval => String_From_Name_Buffer);
5470 end Get_Default_External_Name;
5471
5472 --------------------------
5473 -- Get_Enclosing_Object --
5474 --------------------------
5475
5476 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
5477 begin
5478 if Is_Entity_Name (N) then
5479 return Entity (N);
5480 else
5481 case Nkind (N) is
5482 when N_Indexed_Component |
5483 N_Slice |
5484 N_Selected_Component =>
5485
5486 -- If not generating code, a dereference may be left implicit.
5487 -- In thoses cases, return Empty.
5488
5489 if Is_Access_Type (Etype (Prefix (N))) then
5490 return Empty;
5491 else
5492 return Get_Enclosing_Object (Prefix (N));
5493 end if;
5494
5495 when N_Type_Conversion =>
5496 return Get_Enclosing_Object (Expression (N));
5497
5498 when others =>
5499 return Empty;
5500 end case;
5501 end if;
5502 end Get_Enclosing_Object;
5503
5504 ---------------------------
5505 -- Get_Enum_Lit_From_Pos --
5506 ---------------------------
5507
5508 function Get_Enum_Lit_From_Pos
5509 (T : Entity_Id;
5510 Pos : Uint;
5511 Loc : Source_Ptr) return Node_Id
5512 is
5513 Btyp : Entity_Id := Base_Type (T);
5514 Lit : Node_Id;
5515
5516 begin
5517 -- In the case where the literal is of type Character, Wide_Character
5518 -- or Wide_Wide_Character or of a type derived from them, there needs
5519 -- to be some special handling since there is no explicit chain of
5520 -- literals to search. Instead, an N_Character_Literal node is created
5521 -- with the appropriate Char_Code and Chars fields.
5522
5523 if Is_Standard_Character_Type (T) then
5524 Set_Character_Literal_Name (UI_To_CC (Pos));
5525 return
5526 Make_Character_Literal (Loc,
5527 Chars => Name_Find,
5528 Char_Literal_Value => Pos);
5529
5530 -- For all other cases, we have a complete table of literals, and
5531 -- we simply iterate through the chain of literal until the one
5532 -- with the desired position value is found.
5533 --
5534
5535 else
5536 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
5537 Btyp := Full_View (Btyp);
5538 end if;
5539
5540 Lit := First_Literal (Btyp);
5541 for J in 1 .. UI_To_Int (Pos) loop
5542 Next_Literal (Lit);
5543 end loop;
5544
5545 return New_Occurrence_Of (Lit, Loc);
5546 end if;
5547 end Get_Enum_Lit_From_Pos;
5548
5549 ---------------------------------
5550 -- Get_Ensures_From_CTC_Pragma --
5551 ---------------------------------
5552
5553 function Get_Ensures_From_CTC_Pragma (N : Node_Id) return Node_Id is
5554 Args : constant List_Id := Pragma_Argument_Associations (N);
5555 Res : Node_Id;
5556
5557 begin
5558 if List_Length (Args) = 4 then
5559 Res := Pick (Args, 4);
5560
5561 elsif List_Length (Args) = 3 then
5562 Res := Pick (Args, 3);
5563
5564 if Chars (Res) /= Name_Ensures then
5565 Res := Empty;
5566 end if;
5567
5568 else
5569 Res := Empty;
5570 end if;
5571
5572 return Res;
5573 end Get_Ensures_From_CTC_Pragma;
5574
5575 ------------------------
5576 -- Get_Generic_Entity --
5577 ------------------------
5578
5579 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
5580 Ent : constant Entity_Id := Entity (Name (N));
5581 begin
5582 if Present (Renamed_Object (Ent)) then
5583 return Renamed_Object (Ent);
5584 else
5585 return Ent;
5586 end if;
5587 end Get_Generic_Entity;
5588
5589 -------------------------------------
5590 -- Get_Incomplete_View_Of_Ancestor --
5591 -------------------------------------
5592
5593 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
5594 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
5595 Par_Scope : Entity_Id;
5596 Par_Type : Entity_Id;
5597
5598 begin
5599 -- The incomplete view of an ancestor is only relevant for private
5600 -- derived types in child units.
5601
5602 if not Is_Derived_Type (E)
5603 or else not Is_Child_Unit (Cur_Unit)
5604 then
5605 return Empty;
5606
5607 else
5608 Par_Scope := Scope (Cur_Unit);
5609 if No (Par_Scope) then
5610 return Empty;
5611 end if;
5612
5613 Par_Type := Etype (Base_Type (E));
5614
5615 -- Traverse list of ancestor types until we find one declared in
5616 -- a parent or grandparent unit (two levels seem sufficient).
5617
5618 while Present (Par_Type) loop
5619 if Scope (Par_Type) = Par_Scope
5620 or else Scope (Par_Type) = Scope (Par_Scope)
5621 then
5622 return Par_Type;
5623
5624 elsif not Is_Derived_Type (Par_Type) then
5625 return Empty;
5626
5627 else
5628 Par_Type := Etype (Base_Type (Par_Type));
5629 end if;
5630 end loop;
5631
5632 -- If none found, there is no relevant ancestor type.
5633
5634 return Empty;
5635 end if;
5636 end Get_Incomplete_View_Of_Ancestor;
5637
5638 ----------------------
5639 -- Get_Index_Bounds --
5640 ----------------------
5641
5642 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
5643 Kind : constant Node_Kind := Nkind (N);
5644 R : Node_Id;
5645
5646 begin
5647 if Kind = N_Range then
5648 L := Low_Bound (N);
5649 H := High_Bound (N);
5650
5651 elsif Kind = N_Subtype_Indication then
5652 R := Range_Expression (Constraint (N));
5653
5654 if R = Error then
5655 L := Error;
5656 H := Error;
5657 return;
5658
5659 else
5660 L := Low_Bound (Range_Expression (Constraint (N)));
5661 H := High_Bound (Range_Expression (Constraint (N)));
5662 end if;
5663
5664 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
5665 if Error_Posted (Scalar_Range (Entity (N))) then
5666 L := Error;
5667 H := Error;
5668
5669 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
5670 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
5671
5672 else
5673 L := Low_Bound (Scalar_Range (Entity (N)));
5674 H := High_Bound (Scalar_Range (Entity (N)));
5675 end if;
5676
5677 else
5678 -- N is an expression, indicating a range with one value
5679
5680 L := N;
5681 H := N;
5682 end if;
5683 end Get_Index_Bounds;
5684
5685 ----------------------------------
5686 -- Get_Library_Unit_Name_string --
5687 ----------------------------------
5688
5689 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
5690 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
5691
5692 begin
5693 Get_Unit_Name_String (Unit_Name_Id);
5694
5695 -- Remove seven last character (" (spec)" or " (body)")
5696
5697 Name_Len := Name_Len - 7;
5698 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
5699 end Get_Library_Unit_Name_String;
5700
5701 ------------------------
5702 -- Get_Name_Entity_Id --
5703 ------------------------
5704
5705 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
5706 begin
5707 return Entity_Id (Get_Name_Table_Info (Id));
5708 end Get_Name_Entity_Id;
5709
5710 ------------------------------
5711 -- Get_Name_From_CTC_Pragma --
5712 ------------------------------
5713
5714 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
5715 Arg : constant Node_Id :=
5716 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
5717 begin
5718 return Strval (Expr_Value_S (Arg));
5719 end Get_Name_From_CTC_Pragma;
5720
5721 -------------------
5722 -- Get_Pragma_Id --
5723 -------------------
5724
5725 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
5726 begin
5727 return Get_Pragma_Id (Pragma_Name (N));
5728 end Get_Pragma_Id;
5729
5730 ---------------------------
5731 -- Get_Referenced_Object --
5732 ---------------------------
5733
5734 function Get_Referenced_Object (N : Node_Id) return Node_Id is
5735 R : Node_Id;
5736
5737 begin
5738 R := N;
5739 while Is_Entity_Name (R)
5740 and then Present (Renamed_Object (Entity (R)))
5741 loop
5742 R := Renamed_Object (Entity (R));
5743 end loop;
5744
5745 return R;
5746 end Get_Referenced_Object;
5747
5748 ------------------------
5749 -- Get_Renamed_Entity --
5750 ------------------------
5751
5752 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
5753 R : Entity_Id;
5754
5755 begin
5756 R := E;
5757 while Present (Renamed_Entity (R)) loop
5758 R := Renamed_Entity (R);
5759 end loop;
5760
5761 return R;
5762 end Get_Renamed_Entity;
5763
5764 ----------------------------------
5765 -- Get_Requires_From_CTC_Pragma --
5766 ----------------------------------
5767
5768 function Get_Requires_From_CTC_Pragma (N : Node_Id) return Node_Id is
5769 Args : constant List_Id := Pragma_Argument_Associations (N);
5770 Res : Node_Id;
5771
5772 begin
5773 if List_Length (Args) >= 3 then
5774 Res := Pick (Args, 3);
5775
5776 if Chars (Res) /= Name_Requires then
5777 Res := Empty;
5778 end if;
5779
5780 else
5781 Res := Empty;
5782 end if;
5783
5784 return Res;
5785 end Get_Requires_From_CTC_Pragma;
5786
5787 -------------------------
5788 -- Get_Subprogram_Body --
5789 -------------------------
5790
5791 function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
5792 Decl : Node_Id;
5793
5794 begin
5795 Decl := Unit_Declaration_Node (E);
5796
5797 if Nkind (Decl) = N_Subprogram_Body then
5798 return Decl;
5799
5800 -- The below comment is bad, because it is possible for
5801 -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
5802
5803 else -- Nkind (Decl) = N_Subprogram_Declaration
5804
5805 if Present (Corresponding_Body (Decl)) then
5806 return Unit_Declaration_Node (Corresponding_Body (Decl));
5807
5808 -- Imported subprogram case
5809
5810 else
5811 return Empty;
5812 end if;
5813 end if;
5814 end Get_Subprogram_Body;
5815
5816 ---------------------------
5817 -- Get_Subprogram_Entity --
5818 ---------------------------
5819
5820 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
5821 Subp : Node_Id;
5822 Subp_Id : Entity_Id;
5823
5824 begin
5825 if Nkind (Nod) = N_Accept_Statement then
5826 Subp := Entry_Direct_Name (Nod);
5827
5828 elsif Nkind (Nod) = N_Slice then
5829 Subp := Prefix (Nod);
5830
5831 else
5832 Subp := Name (Nod);
5833 end if;
5834
5835 -- Strip the subprogram call
5836
5837 loop
5838 if Nkind_In (Subp, N_Explicit_Dereference,
5839 N_Indexed_Component,
5840 N_Selected_Component)
5841 then
5842 Subp := Prefix (Subp);
5843
5844 elsif Nkind_In (Subp, N_Type_Conversion,
5845 N_Unchecked_Type_Conversion)
5846 then
5847 Subp := Expression (Subp);
5848
5849 else
5850 exit;
5851 end if;
5852 end loop;
5853
5854 -- Extract the entity of the subprogram call
5855
5856 if Is_Entity_Name (Subp) then
5857 Subp_Id := Entity (Subp);
5858
5859 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
5860 Subp_Id := Directly_Designated_Type (Subp_Id);
5861 end if;
5862
5863 if Is_Subprogram (Subp_Id) then
5864 return Subp_Id;
5865 else
5866 return Empty;
5867 end if;
5868
5869 -- The search did not find a construct that denotes a subprogram
5870
5871 else
5872 return Empty;
5873 end if;
5874 end Get_Subprogram_Entity;
5875
5876 -----------------------------
5877 -- Get_Task_Body_Procedure --
5878 -----------------------------
5879
5880 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
5881 begin
5882 -- Note: A task type may be the completion of a private type with
5883 -- discriminants. When performing elaboration checks on a task
5884 -- declaration, the current view of the type may be the private one,
5885 -- and the procedure that holds the body of the task is held in its
5886 -- underlying type.
5887
5888 -- This is an odd function, why not have Task_Body_Procedure do
5889 -- the following digging???
5890
5891 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
5892 end Get_Task_Body_Procedure;
5893
5894 -----------------------
5895 -- Has_Access_Values --
5896 -----------------------
5897
5898 function Has_Access_Values (T : Entity_Id) return Boolean is
5899 Typ : constant Entity_Id := Underlying_Type (T);
5900
5901 begin
5902 -- Case of a private type which is not completed yet. This can only
5903 -- happen in the case of a generic format type appearing directly, or
5904 -- as a component of the type to which this function is being applied
5905 -- at the top level. Return False in this case, since we certainly do
5906 -- not know that the type contains access types.
5907
5908 if No (Typ) then
5909 return False;
5910
5911 elsif Is_Access_Type (Typ) then
5912 return True;
5913
5914 elsif Is_Array_Type (Typ) then
5915 return Has_Access_Values (Component_Type (Typ));
5916
5917 elsif Is_Record_Type (Typ) then
5918 declare
5919 Comp : Entity_Id;
5920
5921 begin
5922 -- Loop to Check components
5923
5924 Comp := First_Component_Or_Discriminant (Typ);
5925 while Present (Comp) loop
5926
5927 -- Check for access component, tag field does not count, even
5928 -- though it is implemented internally using an access type.
5929
5930 if Has_Access_Values (Etype (Comp))
5931 and then Chars (Comp) /= Name_uTag
5932 then
5933 return True;
5934 end if;
5935
5936 Next_Component_Or_Discriminant (Comp);
5937 end loop;
5938 end;
5939
5940 return False;
5941
5942 else
5943 return False;
5944 end if;
5945 end Has_Access_Values;
5946
5947 ------------------------------
5948 -- Has_Compatible_Alignment --
5949 ------------------------------
5950
5951 function Has_Compatible_Alignment
5952 (Obj : Entity_Id;
5953 Expr : Node_Id) return Alignment_Result
5954 is
5955 function Has_Compatible_Alignment_Internal
5956 (Obj : Entity_Id;
5957 Expr : Node_Id;
5958 Default : Alignment_Result) return Alignment_Result;
5959 -- This is the internal recursive function that actually does the work.
5960 -- There is one additional parameter, which says what the result should
5961 -- be if no alignment information is found, and there is no definite
5962 -- indication of compatible alignments. At the outer level, this is set
5963 -- to Unknown, but for internal recursive calls in the case where types
5964 -- are known to be correct, it is set to Known_Compatible.
5965
5966 ---------------------------------------
5967 -- Has_Compatible_Alignment_Internal --
5968 ---------------------------------------
5969
5970 function Has_Compatible_Alignment_Internal
5971 (Obj : Entity_Id;
5972 Expr : Node_Id;
5973 Default : Alignment_Result) return Alignment_Result
5974 is
5975 Result : Alignment_Result := Known_Compatible;
5976 -- Holds the current status of the result. Note that once a value of
5977 -- Known_Incompatible is set, it is sticky and does not get changed
5978 -- to Unknown (the value in Result only gets worse as we go along,
5979 -- never better).
5980
5981 Offs : Uint := No_Uint;
5982 -- Set to a factor of the offset from the base object when Expr is a
5983 -- selected or indexed component, based on Component_Bit_Offset and
5984 -- Component_Size respectively. A negative value is used to represent
5985 -- a value which is not known at compile time.
5986
5987 procedure Check_Prefix;
5988 -- Checks the prefix recursively in the case where the expression
5989 -- is an indexed or selected component.
5990
5991 procedure Set_Result (R : Alignment_Result);
5992 -- If R represents a worse outcome (unknown instead of known
5993 -- compatible, or known incompatible), then set Result to R.
5994
5995 ------------------
5996 -- Check_Prefix --
5997 ------------------
5998
5999 procedure Check_Prefix is
6000 begin
6001 -- The subtlety here is that in doing a recursive call to check
6002 -- the prefix, we have to decide what to do in the case where we
6003 -- don't find any specific indication of an alignment problem.
6004
6005 -- At the outer level, we normally set Unknown as the result in
6006 -- this case, since we can only set Known_Compatible if we really
6007 -- know that the alignment value is OK, but for the recursive
6008 -- call, in the case where the types match, and we have not
6009 -- specified a peculiar alignment for the object, we are only
6010 -- concerned about suspicious rep clauses, the default case does
6011 -- not affect us, since the compiler will, in the absence of such
6012 -- rep clauses, ensure that the alignment is correct.
6013
6014 if Default = Known_Compatible
6015 or else
6016 (Etype (Obj) = Etype (Expr)
6017 and then (Unknown_Alignment (Obj)
6018 or else
6019 Alignment (Obj) = Alignment (Etype (Obj))))
6020 then
6021 Set_Result
6022 (Has_Compatible_Alignment_Internal
6023 (Obj, Prefix (Expr), Known_Compatible));
6024
6025 -- In all other cases, we need a full check on the prefix
6026
6027 else
6028 Set_Result
6029 (Has_Compatible_Alignment_Internal
6030 (Obj, Prefix (Expr), Unknown));
6031 end if;
6032 end Check_Prefix;
6033
6034 ----------------
6035 -- Set_Result --
6036 ----------------
6037
6038 procedure Set_Result (R : Alignment_Result) is
6039 begin
6040 if R > Result then
6041 Result := R;
6042 end if;
6043 end Set_Result;
6044
6045 -- Start of processing for Has_Compatible_Alignment_Internal
6046
6047 begin
6048 -- If Expr is a selected component, we must make sure there is no
6049 -- potentially troublesome component clause, and that the record is
6050 -- not packed.
6051
6052 if Nkind (Expr) = N_Selected_Component then
6053
6054 -- Packed record always generate unknown alignment
6055
6056 if Is_Packed (Etype (Prefix (Expr))) then
6057 Set_Result (Unknown);
6058 end if;
6059
6060 -- Check prefix and component offset
6061
6062 Check_Prefix;
6063 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
6064
6065 -- If Expr is an indexed component, we must make sure there is no
6066 -- potentially troublesome Component_Size clause and that the array
6067 -- is not bit-packed.
6068
6069 elsif Nkind (Expr) = N_Indexed_Component then
6070 declare
6071 Typ : constant Entity_Id := Etype (Prefix (Expr));
6072 Ind : constant Node_Id := First_Index (Typ);
6073
6074 begin
6075 -- Bit packed array always generates unknown alignment
6076
6077 if Is_Bit_Packed_Array (Typ) then
6078 Set_Result (Unknown);
6079 end if;
6080
6081 -- Check prefix and component offset
6082
6083 Check_Prefix;
6084 Offs := Component_Size (Typ);
6085
6086 -- Small optimization: compute the full offset when possible
6087
6088 if Offs /= No_Uint
6089 and then Offs > Uint_0
6090 and then Present (Ind)
6091 and then Nkind (Ind) = N_Range
6092 and then Compile_Time_Known_Value (Low_Bound (Ind))
6093 and then Compile_Time_Known_Value (First (Expressions (Expr)))
6094 then
6095 Offs := Offs * (Expr_Value (First (Expressions (Expr)))
6096 - Expr_Value (Low_Bound ((Ind))));
6097 end if;
6098 end;
6099 end if;
6100
6101 -- If we have a null offset, the result is entirely determined by
6102 -- the base object and has already been computed recursively.
6103
6104 if Offs = Uint_0 then
6105 null;
6106
6107 -- Case where we know the alignment of the object
6108
6109 elsif Known_Alignment (Obj) then
6110 declare
6111 ObjA : constant Uint := Alignment (Obj);
6112 ExpA : Uint := No_Uint;
6113 SizA : Uint := No_Uint;
6114
6115 begin
6116 -- If alignment of Obj is 1, then we are always OK
6117
6118 if ObjA = 1 then
6119 Set_Result (Known_Compatible);
6120
6121 -- Alignment of Obj is greater than 1, so we need to check
6122
6123 else
6124 -- If we have an offset, see if it is compatible
6125
6126 if Offs /= No_Uint and Offs > Uint_0 then
6127 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
6128 Set_Result (Known_Incompatible);
6129 end if;
6130
6131 -- See if Expr is an object with known alignment
6132
6133 elsif Is_Entity_Name (Expr)
6134 and then Known_Alignment (Entity (Expr))
6135 then
6136 ExpA := Alignment (Entity (Expr));
6137
6138 -- Otherwise, we can use the alignment of the type of
6139 -- Expr given that we already checked for
6140 -- discombobulating rep clauses for the cases of indexed
6141 -- and selected components above.
6142
6143 elsif Known_Alignment (Etype (Expr)) then
6144 ExpA := Alignment (Etype (Expr));
6145
6146 -- Otherwise the alignment is unknown
6147
6148 else
6149 Set_Result (Default);
6150 end if;
6151
6152 -- If we got an alignment, see if it is acceptable
6153
6154 if ExpA /= No_Uint and then ExpA < ObjA then
6155 Set_Result (Known_Incompatible);
6156 end if;
6157
6158 -- If Expr is not a piece of a larger object, see if size
6159 -- is given. If so, check that it is not too small for the
6160 -- required alignment.
6161
6162 if Offs /= No_Uint then
6163 null;
6164
6165 -- See if Expr is an object with known size
6166
6167 elsif Is_Entity_Name (Expr)
6168 and then Known_Static_Esize (Entity (Expr))
6169 then
6170 SizA := Esize (Entity (Expr));
6171
6172 -- Otherwise, we check the object size of the Expr type
6173
6174 elsif Known_Static_Esize (Etype (Expr)) then
6175 SizA := Esize (Etype (Expr));
6176 end if;
6177
6178 -- If we got a size, see if it is a multiple of the Obj
6179 -- alignment, if not, then the alignment cannot be
6180 -- acceptable, since the size is always a multiple of the
6181 -- alignment.
6182
6183 if SizA /= No_Uint then
6184 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
6185 Set_Result (Known_Incompatible);
6186 end if;
6187 end if;
6188 end if;
6189 end;
6190
6191 -- If we do not know required alignment, any non-zero offset is a
6192 -- potential problem (but certainly may be OK, so result is unknown).
6193
6194 elsif Offs /= No_Uint then
6195 Set_Result (Unknown);
6196
6197 -- If we can't find the result by direct comparison of alignment
6198 -- values, then there is still one case that we can determine known
6199 -- result, and that is when we can determine that the types are the
6200 -- same, and no alignments are specified. Then we known that the
6201 -- alignments are compatible, even if we don't know the alignment
6202 -- value in the front end.
6203
6204 elsif Etype (Obj) = Etype (Expr) then
6205
6206 -- Types are the same, but we have to check for possible size
6207 -- and alignments on the Expr object that may make the alignment
6208 -- different, even though the types are the same.
6209
6210 if Is_Entity_Name (Expr) then
6211
6212 -- First check alignment of the Expr object. Any alignment less
6213 -- than Maximum_Alignment is worrisome since this is the case
6214 -- where we do not know the alignment of Obj.
6215
6216 if Known_Alignment (Entity (Expr))
6217 and then
6218 UI_To_Int (Alignment (Entity (Expr))) <
6219 Ttypes.Maximum_Alignment
6220 then
6221 Set_Result (Unknown);
6222
6223 -- Now check size of Expr object. Any size that is not an
6224 -- even multiple of Maximum_Alignment is also worrisome
6225 -- since it may cause the alignment of the object to be less
6226 -- than the alignment of the type.
6227
6228 elsif Known_Static_Esize (Entity (Expr))
6229 and then
6230 (UI_To_Int (Esize (Entity (Expr))) mod
6231 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
6232 /= 0
6233 then
6234 Set_Result (Unknown);
6235
6236 -- Otherwise same type is decisive
6237
6238 else
6239 Set_Result (Known_Compatible);
6240 end if;
6241 end if;
6242
6243 -- Another case to deal with is when there is an explicit size or
6244 -- alignment clause when the types are not the same. If so, then the
6245 -- result is Unknown. We don't need to do this test if the Default is
6246 -- Unknown, since that result will be set in any case.
6247
6248 elsif Default /= Unknown
6249 and then (Has_Size_Clause (Etype (Expr))
6250 or else
6251 Has_Alignment_Clause (Etype (Expr)))
6252 then
6253 Set_Result (Unknown);
6254
6255 -- If no indication found, set default
6256
6257 else
6258 Set_Result (Default);
6259 end if;
6260
6261 -- Return worst result found
6262
6263 return Result;
6264 end Has_Compatible_Alignment_Internal;
6265
6266 -- Start of processing for Has_Compatible_Alignment
6267
6268 begin
6269 -- If Obj has no specified alignment, then set alignment from the type
6270 -- alignment. Perhaps we should always do this, but for sure we should
6271 -- do it when there is an address clause since we can do more if the
6272 -- alignment is known.
6273
6274 if Unknown_Alignment (Obj) then
6275 Set_Alignment (Obj, Alignment (Etype (Obj)));
6276 end if;
6277
6278 -- Now do the internal call that does all the work
6279
6280 return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
6281 end Has_Compatible_Alignment;
6282
6283 ----------------------
6284 -- Has_Declarations --
6285 ----------------------
6286
6287 function Has_Declarations (N : Node_Id) return Boolean is
6288 begin
6289 return Nkind_In (Nkind (N), N_Accept_Statement,
6290 N_Block_Statement,
6291 N_Compilation_Unit_Aux,
6292 N_Entry_Body,
6293 N_Package_Body,
6294 N_Protected_Body,
6295 N_Subprogram_Body,
6296 N_Task_Body,
6297 N_Package_Specification);
6298 end Has_Declarations;
6299
6300 -------------------
6301 -- Has_Denormals --
6302 -------------------
6303
6304 function Has_Denormals (E : Entity_Id) return Boolean is
6305 begin
6306 return Is_Floating_Point_Type (E)
6307 and then Denorm_On_Target
6308 and then not Vax_Float (E);
6309 end Has_Denormals;
6310
6311 -------------------------------------------
6312 -- Has_Discriminant_Dependent_Constraint --
6313 -------------------------------------------
6314
6315 function Has_Discriminant_Dependent_Constraint
6316 (Comp : Entity_Id) return Boolean
6317 is
6318 Comp_Decl : constant Node_Id := Parent (Comp);
6319 Subt_Indic : constant Node_Id :=
6320 Subtype_Indication (Component_Definition (Comp_Decl));
6321 Constr : Node_Id;
6322 Assn : Node_Id;
6323
6324 begin
6325 if Nkind (Subt_Indic) = N_Subtype_Indication then
6326 Constr := Constraint (Subt_Indic);
6327
6328 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
6329 Assn := First (Constraints (Constr));
6330 while Present (Assn) loop
6331 case Nkind (Assn) is
6332 when N_Subtype_Indication |
6333 N_Range |
6334 N_Identifier
6335 =>
6336 if Depends_On_Discriminant (Assn) then
6337 return True;
6338 end if;
6339
6340 when N_Discriminant_Association =>
6341 if Depends_On_Discriminant (Expression (Assn)) then
6342 return True;
6343 end if;
6344
6345 when others =>
6346 null;
6347
6348 end case;
6349
6350 Next (Assn);
6351 end loop;
6352 end if;
6353 end if;
6354
6355 return False;
6356 end Has_Discriminant_Dependent_Constraint;
6357
6358 --------------------
6359 -- Has_Infinities --
6360 --------------------
6361
6362 function Has_Infinities (E : Entity_Id) return Boolean is
6363 begin
6364 return
6365 Is_Floating_Point_Type (E)
6366 and then Nkind (Scalar_Range (E)) = N_Range
6367 and then Includes_Infinities (Scalar_Range (E));
6368 end Has_Infinities;
6369
6370 --------------------
6371 -- Has_Interfaces --
6372 --------------------
6373
6374 function Has_Interfaces
6375 (T : Entity_Id;
6376 Use_Full_View : Boolean := True) return Boolean
6377 is
6378 Typ : Entity_Id := Base_Type (T);
6379
6380 begin
6381 -- Handle concurrent types
6382
6383 if Is_Concurrent_Type (Typ) then
6384 Typ := Corresponding_Record_Type (Typ);
6385 end if;
6386
6387 if not Present (Typ)
6388 or else not Is_Record_Type (Typ)
6389 or else not Is_Tagged_Type (Typ)
6390 then
6391 return False;
6392 end if;
6393
6394 -- Handle private types
6395
6396 if Use_Full_View
6397 and then Present (Full_View (Typ))
6398 then
6399 Typ := Full_View (Typ);
6400 end if;
6401
6402 -- Handle concurrent record types
6403
6404 if Is_Concurrent_Record_Type (Typ)
6405 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
6406 then
6407 return True;
6408 end if;
6409
6410 loop
6411 if Is_Interface (Typ)
6412 or else
6413 (Is_Record_Type (Typ)
6414 and then Present (Interfaces (Typ))
6415 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
6416 then
6417 return True;
6418 end if;
6419
6420 exit when Etype (Typ) = Typ
6421
6422 -- Handle private types
6423
6424 or else (Present (Full_View (Etype (Typ)))
6425 and then Full_View (Etype (Typ)) = Typ)
6426
6427 -- Protect the frontend against wrong source with cyclic
6428 -- derivations
6429
6430 or else Etype (Typ) = T;
6431
6432 -- Climb to the ancestor type handling private types
6433
6434 if Present (Full_View (Etype (Typ))) then
6435 Typ := Full_View (Etype (Typ));
6436 else
6437 Typ := Etype (Typ);
6438 end if;
6439 end loop;
6440
6441 return False;
6442 end Has_Interfaces;
6443
6444 ------------------------
6445 -- Has_Null_Exclusion --
6446 ------------------------
6447
6448 function Has_Null_Exclusion (N : Node_Id) return Boolean is
6449 begin
6450 case Nkind (N) is
6451 when N_Access_Definition |
6452 N_Access_Function_Definition |
6453 N_Access_Procedure_Definition |
6454 N_Access_To_Object_Definition |
6455 N_Allocator |
6456 N_Derived_Type_Definition |
6457 N_Function_Specification |
6458 N_Subtype_Declaration =>
6459 return Null_Exclusion_Present (N);
6460
6461 when N_Component_Definition |
6462 N_Formal_Object_Declaration |
6463 N_Object_Renaming_Declaration =>
6464 if Present (Subtype_Mark (N)) then
6465 return Null_Exclusion_Present (N);
6466 else pragma Assert (Present (Access_Definition (N)));
6467 return Null_Exclusion_Present (Access_Definition (N));
6468 end if;
6469
6470 when N_Discriminant_Specification =>
6471 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
6472 return Null_Exclusion_Present (Discriminant_Type (N));
6473 else
6474 return Null_Exclusion_Present (N);
6475 end if;
6476
6477 when N_Object_Declaration =>
6478 if Nkind (Object_Definition (N)) = N_Access_Definition then
6479 return Null_Exclusion_Present (Object_Definition (N));
6480 else
6481 return Null_Exclusion_Present (N);
6482 end if;
6483
6484 when N_Parameter_Specification =>
6485 if Nkind (Parameter_Type (N)) = N_Access_Definition then
6486 return Null_Exclusion_Present (Parameter_Type (N));
6487 else
6488 return Null_Exclusion_Present (N);
6489 end if;
6490
6491 when others =>
6492 return False;
6493
6494 end case;
6495 end Has_Null_Exclusion;
6496
6497 ------------------------
6498 -- Has_Null_Extension --
6499 ------------------------
6500
6501 function Has_Null_Extension (T : Entity_Id) return Boolean is
6502 B : constant Entity_Id := Base_Type (T);
6503 Comps : Node_Id;
6504 Ext : Node_Id;
6505
6506 begin
6507 if Nkind (Parent (B)) = N_Full_Type_Declaration
6508 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
6509 then
6510 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
6511
6512 if Present (Ext) then
6513 if Null_Present (Ext) then
6514 return True;
6515 else
6516 Comps := Component_List (Ext);
6517
6518 -- The null component list is rewritten during analysis to
6519 -- include the parent component. Any other component indicates
6520 -- that the extension was not originally null.
6521
6522 return Null_Present (Comps)
6523 or else No (Next (First (Component_Items (Comps))));
6524 end if;
6525 else
6526 return False;
6527 end if;
6528
6529 else
6530 return False;
6531 end if;
6532 end Has_Null_Extension;
6533
6534 -------------------------------
6535 -- Has_Overriding_Initialize --
6536 -------------------------------
6537
6538 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
6539 BT : constant Entity_Id := Base_Type (T);
6540 P : Elmt_Id;
6541
6542 begin
6543 if Is_Controlled (BT) then
6544 if Is_RTU (Scope (BT), Ada_Finalization) then
6545 return False;
6546
6547 elsif Present (Primitive_Operations (BT)) then
6548 P := First_Elmt (Primitive_Operations (BT));
6549 while Present (P) loop
6550 declare
6551 Init : constant Entity_Id := Node (P);
6552 Formal : constant Entity_Id := First_Formal (Init);
6553 begin
6554 if Ekind (Init) = E_Procedure
6555 and then Chars (Init) = Name_Initialize
6556 and then Comes_From_Source (Init)
6557 and then Present (Formal)
6558 and then Etype (Formal) = BT
6559 and then No (Next_Formal (Formal))
6560 and then (Ada_Version < Ada_2012
6561 or else not Null_Present (Parent (Init)))
6562 then
6563 return True;
6564 end if;
6565 end;
6566
6567 Next_Elmt (P);
6568 end loop;
6569 end if;
6570
6571 -- Here if type itself does not have a non-null Initialize operation:
6572 -- check immediate ancestor.
6573
6574 if Is_Derived_Type (BT)
6575 and then Has_Overriding_Initialize (Etype (BT))
6576 then
6577 return True;
6578 end if;
6579 end if;
6580
6581 return False;
6582 end Has_Overriding_Initialize;
6583
6584 --------------------------------------
6585 -- Has_Preelaborable_Initialization --
6586 --------------------------------------
6587
6588 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
6589 Has_PE : Boolean;
6590
6591 procedure Check_Components (E : Entity_Id);
6592 -- Check component/discriminant chain, sets Has_PE False if a component
6593 -- or discriminant does not meet the preelaborable initialization rules.
6594
6595 ----------------------
6596 -- Check_Components --
6597 ----------------------
6598
6599 procedure Check_Components (E : Entity_Id) is
6600 Ent : Entity_Id;
6601 Exp : Node_Id;
6602
6603 function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
6604 -- Returns True if and only if the expression denoted by N does not
6605 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
6606
6607 ---------------------------------
6608 -- Is_Preelaborable_Expression --
6609 ---------------------------------
6610
6611 function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
6612 Exp : Node_Id;
6613 Assn : Node_Id;
6614 Choice : Node_Id;
6615 Comp_Type : Entity_Id;
6616 Is_Array_Aggr : Boolean;
6617
6618 begin
6619 if Is_Static_Expression (N) then
6620 return True;
6621
6622 elsif Nkind (N) = N_Null then
6623 return True;
6624
6625 -- Attributes are allowed in general, even if their prefix is a
6626 -- formal type. (It seems that certain attributes known not to be
6627 -- static might not be allowed, but there are no rules to prevent
6628 -- them.)
6629
6630 elsif Nkind (N) = N_Attribute_Reference then
6631 return True;
6632
6633 -- The name of a discriminant evaluated within its parent type is
6634 -- defined to be preelaborable (10.2.1(8)). Note that we test for
6635 -- names that denote discriminals as well as discriminants to
6636 -- catch references occurring within init procs.
6637
6638 elsif Is_Entity_Name (N)
6639 and then
6640 (Ekind (Entity (N)) = E_Discriminant
6641 or else
6642 ((Ekind (Entity (N)) = E_Constant
6643 or else Ekind (Entity (N)) = E_In_Parameter)
6644 and then Present (Discriminal_Link (Entity (N)))))
6645 then
6646 return True;
6647
6648 elsif Nkind (N) = N_Qualified_Expression then
6649 return Is_Preelaborable_Expression (Expression (N));
6650
6651 -- For aggregates we have to check that each of the associations
6652 -- is preelaborable.
6653
6654 elsif Nkind (N) = N_Aggregate
6655 or else Nkind (N) = N_Extension_Aggregate
6656 then
6657 Is_Array_Aggr := Is_Array_Type (Etype (N));
6658
6659 if Is_Array_Aggr then
6660 Comp_Type := Component_Type (Etype (N));
6661 end if;
6662
6663 -- Check the ancestor part of extension aggregates, which must
6664 -- be either the name of a type that has preelaborable init or
6665 -- an expression that is preelaborable.
6666
6667 if Nkind (N) = N_Extension_Aggregate then
6668 declare
6669 Anc_Part : constant Node_Id := Ancestor_Part (N);
6670
6671 begin
6672 if Is_Entity_Name (Anc_Part)
6673 and then Is_Type (Entity (Anc_Part))
6674 then
6675 if not Has_Preelaborable_Initialization
6676 (Entity (Anc_Part))
6677 then
6678 return False;
6679 end if;
6680
6681 elsif not Is_Preelaborable_Expression (Anc_Part) then
6682 return False;
6683 end if;
6684 end;
6685 end if;
6686
6687 -- Check positional associations
6688
6689 Exp := First (Expressions (N));
6690 while Present (Exp) loop
6691 if not Is_Preelaborable_Expression (Exp) then
6692 return False;
6693 end if;
6694
6695 Next (Exp);
6696 end loop;
6697
6698 -- Check named associations
6699
6700 Assn := First (Component_Associations (N));
6701 while Present (Assn) loop
6702 Choice := First (Choices (Assn));
6703 while Present (Choice) loop
6704 if Is_Array_Aggr then
6705 if Nkind (Choice) = N_Others_Choice then
6706 null;
6707
6708 elsif Nkind (Choice) = N_Range then
6709 if not Is_Static_Range (Choice) then
6710 return False;
6711 end if;
6712
6713 elsif not Is_Static_Expression (Choice) then
6714 return False;
6715 end if;
6716
6717 else
6718 Comp_Type := Etype (Choice);
6719 end if;
6720
6721 Next (Choice);
6722 end loop;
6723
6724 -- If the association has a <> at this point, then we have
6725 -- to check whether the component's type has preelaborable
6726 -- initialization. Note that this only occurs when the
6727 -- association's corresponding component does not have a
6728 -- default expression, the latter case having already been
6729 -- expanded as an expression for the association.
6730
6731 if Box_Present (Assn) then
6732 if not Has_Preelaborable_Initialization (Comp_Type) then
6733 return False;
6734 end if;
6735
6736 -- In the expression case we check whether the expression
6737 -- is preelaborable.
6738
6739 elsif
6740 not Is_Preelaborable_Expression (Expression (Assn))
6741 then
6742 return False;
6743 end if;
6744
6745 Next (Assn);
6746 end loop;
6747
6748 -- If we get here then aggregate as a whole is preelaborable
6749
6750 return True;
6751
6752 -- All other cases are not preelaborable
6753
6754 else
6755 return False;
6756 end if;
6757 end Is_Preelaborable_Expression;
6758
6759 -- Start of processing for Check_Components
6760
6761 begin
6762 -- Loop through entities of record or protected type
6763
6764 Ent := E;
6765 while Present (Ent) loop
6766
6767 -- We are interested only in components and discriminants
6768
6769 Exp := Empty;
6770
6771 case Ekind (Ent) is
6772 when E_Component =>
6773
6774 -- Get default expression if any. If there is no declaration
6775 -- node, it means we have an internal entity. The parent and
6776 -- tag fields are examples of such entities. For such cases,
6777 -- we just test the type of the entity.
6778
6779 if Present (Declaration_Node (Ent)) then
6780 Exp := Expression (Declaration_Node (Ent));
6781 end if;
6782
6783 when E_Discriminant =>
6784
6785 -- Note: for a renamed discriminant, the Declaration_Node
6786 -- may point to the one from the ancestor, and have a
6787 -- different expression, so use the proper attribute to
6788 -- retrieve the expression from the derived constraint.
6789
6790 Exp := Discriminant_Default_Value (Ent);
6791
6792 when others =>
6793 goto Check_Next_Entity;
6794 end case;
6795
6796 -- A component has PI if it has no default expression and the
6797 -- component type has PI.
6798
6799 if No (Exp) then
6800 if not Has_Preelaborable_Initialization (Etype (Ent)) then
6801 Has_PE := False;
6802 exit;
6803 end if;
6804
6805 -- Require the default expression to be preelaborable
6806
6807 elsif not Is_Preelaborable_Expression (Exp) then
6808 Has_PE := False;
6809 exit;
6810 end if;
6811
6812 <<Check_Next_Entity>>
6813 Next_Entity (Ent);
6814 end loop;
6815 end Check_Components;
6816
6817 -- Start of processing for Has_Preelaborable_Initialization
6818
6819 begin
6820 -- Immediate return if already marked as known preelaborable init. This
6821 -- covers types for which this function has already been called once
6822 -- and returned True (in which case the result is cached), and also
6823 -- types to which a pragma Preelaborable_Initialization applies.
6824
6825 if Known_To_Have_Preelab_Init (E) then
6826 return True;
6827 end if;
6828
6829 -- If the type is a subtype representing a generic actual type, then
6830 -- test whether its base type has preelaborable initialization since
6831 -- the subtype representing the actual does not inherit this attribute
6832 -- from the actual or formal. (but maybe it should???)
6833
6834 if Is_Generic_Actual_Type (E) then
6835 return Has_Preelaborable_Initialization (Base_Type (E));
6836 end if;
6837
6838 -- All elementary types have preelaborable initialization
6839
6840 if Is_Elementary_Type (E) then
6841 Has_PE := True;
6842
6843 -- Array types have PI if the component type has PI
6844
6845 elsif Is_Array_Type (E) then
6846 Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
6847
6848 -- A derived type has preelaborable initialization if its parent type
6849 -- has preelaborable initialization and (in the case of a derived record
6850 -- extension) if the non-inherited components all have preelaborable
6851 -- initialization. However, a user-defined controlled type with an
6852 -- overriding Initialize procedure does not have preelaborable
6853 -- initialization.
6854
6855 elsif Is_Derived_Type (E) then
6856
6857 -- If the derived type is a private extension then it doesn't have
6858 -- preelaborable initialization.
6859
6860 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
6861 return False;
6862 end if;
6863
6864 -- First check whether ancestor type has preelaborable initialization
6865
6866 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
6867
6868 -- If OK, check extension components (if any)
6869
6870 if Has_PE and then Is_Record_Type (E) then
6871 Check_Components (First_Entity (E));
6872 end if;
6873
6874 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
6875 -- with a user defined Initialize procedure does not have PI.
6876
6877 if Has_PE
6878 and then Is_Controlled (E)
6879 and then Has_Overriding_Initialize (E)
6880 then
6881 Has_PE := False;
6882 end if;
6883
6884 -- Private types not derived from a type having preelaborable init and
6885 -- that are not marked with pragma Preelaborable_Initialization do not
6886 -- have preelaborable initialization.
6887
6888 elsif Is_Private_Type (E) then
6889 return False;
6890
6891 -- Record type has PI if it is non private and all components have PI
6892
6893 elsif Is_Record_Type (E) then
6894 Has_PE := True;
6895 Check_Components (First_Entity (E));
6896
6897 -- Protected types must not have entries, and components must meet
6898 -- same set of rules as for record components.
6899
6900 elsif Is_Protected_Type (E) then
6901 if Has_Entries (E) then
6902 Has_PE := False;
6903 else
6904 Has_PE := True;
6905 Check_Components (First_Entity (E));
6906 Check_Components (First_Private_Entity (E));
6907 end if;
6908
6909 -- Type System.Address always has preelaborable initialization
6910
6911 elsif Is_RTE (E, RE_Address) then
6912 Has_PE := True;
6913
6914 -- In all other cases, type does not have preelaborable initialization
6915
6916 else
6917 return False;
6918 end if;
6919
6920 -- If type has preelaborable initialization, cache result
6921
6922 if Has_PE then
6923 Set_Known_To_Have_Preelab_Init (E);
6924 end if;
6925
6926 return Has_PE;
6927 end Has_Preelaborable_Initialization;
6928
6929 ---------------------------
6930 -- Has_Private_Component --
6931 ---------------------------
6932
6933 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
6934 Btype : Entity_Id := Base_Type (Type_Id);
6935 Component : Entity_Id;
6936
6937 begin
6938 if Error_Posted (Type_Id)
6939 or else Error_Posted (Btype)
6940 then
6941 return False;
6942 end if;
6943
6944 if Is_Class_Wide_Type (Btype) then
6945 Btype := Root_Type (Btype);
6946 end if;
6947
6948 if Is_Private_Type (Btype) then
6949 declare
6950 UT : constant Entity_Id := Underlying_Type (Btype);
6951 begin
6952 if No (UT) then
6953 if No (Full_View (Btype)) then
6954 return not Is_Generic_Type (Btype)
6955 and then not Is_Generic_Type (Root_Type (Btype));
6956 else
6957 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
6958 end if;
6959 else
6960 return not Is_Frozen (UT) and then Has_Private_Component (UT);
6961 end if;
6962 end;
6963
6964 elsif Is_Array_Type (Btype) then
6965 return Has_Private_Component (Component_Type (Btype));
6966
6967 elsif Is_Record_Type (Btype) then
6968 Component := First_Component (Btype);
6969 while Present (Component) loop
6970 if Has_Private_Component (Etype (Component)) then
6971 return True;
6972 end if;
6973
6974 Next_Component (Component);
6975 end loop;
6976
6977 return False;
6978
6979 elsif Is_Protected_Type (Btype)
6980 and then Present (Corresponding_Record_Type (Btype))
6981 then
6982 return Has_Private_Component (Corresponding_Record_Type (Btype));
6983
6984 else
6985 return False;
6986 end if;
6987 end Has_Private_Component;
6988
6989 ----------------------
6990 -- Has_Signed_Zeros --
6991 ----------------------
6992
6993 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
6994 begin
6995 return Is_Floating_Point_Type (E)
6996 and then Signed_Zeros_On_Target
6997 and then not Vax_Float (E);
6998 end Has_Signed_Zeros;
6999
7000 -----------------------------
7001 -- Has_Static_Array_Bounds --
7002 -----------------------------
7003
7004 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
7005 Ndims : constant Nat := Number_Dimensions (Typ);
7006
7007 Index : Node_Id;
7008 Low : Node_Id;
7009 High : Node_Id;
7010
7011 begin
7012 -- Unconstrained types do not have static bounds
7013
7014 if not Is_Constrained (Typ) then
7015 return False;
7016 end if;
7017
7018 -- First treat string literals specially, as the lower bound and length
7019 -- of string literals are not stored like those of arrays.
7020
7021 -- A string literal always has static bounds
7022
7023 if Ekind (Typ) = E_String_Literal_Subtype then
7024 return True;
7025 end if;
7026
7027 -- Treat all dimensions in turn
7028
7029 Index := First_Index (Typ);
7030 for Indx in 1 .. Ndims loop
7031
7032 -- In case of an erroneous index which is not a discrete type, return
7033 -- that the type is not static.
7034
7035 if not Is_Discrete_Type (Etype (Index))
7036 or else Etype (Index) = Any_Type
7037 then
7038 return False;
7039 end if;
7040
7041 Get_Index_Bounds (Index, Low, High);
7042
7043 if Error_Posted (Low) or else Error_Posted (High) then
7044 return False;
7045 end if;
7046
7047 if Is_OK_Static_Expression (Low)
7048 and then
7049 Is_OK_Static_Expression (High)
7050 then
7051 null;
7052 else
7053 return False;
7054 end if;
7055
7056 Next (Index);
7057 end loop;
7058
7059 -- If we fall through the loop, all indexes matched
7060
7061 return True;
7062 end Has_Static_Array_Bounds;
7063
7064 ----------------
7065 -- Has_Stream --
7066 ----------------
7067
7068 function Has_Stream (T : Entity_Id) return Boolean is
7069 E : Entity_Id;
7070
7071 begin
7072 if No (T) then
7073 return False;
7074
7075 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
7076 return True;
7077
7078 elsif Is_Array_Type (T) then
7079 return Has_Stream (Component_Type (T));
7080
7081 elsif Is_Record_Type (T) then
7082 E := First_Component (T);
7083 while Present (E) loop
7084 if Has_Stream (Etype (E)) then
7085 return True;
7086 else
7087 Next_Component (E);
7088 end if;
7089 end loop;
7090
7091 return False;
7092
7093 elsif Is_Private_Type (T) then
7094 return Has_Stream (Underlying_Type (T));
7095
7096 else
7097 return False;
7098 end if;
7099 end Has_Stream;
7100
7101 ----------------
7102 -- Has_Suffix --
7103 ----------------
7104
7105 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
7106 begin
7107 Get_Name_String (Chars (E));
7108 return Name_Buffer (Name_Len) = Suffix;
7109 end Has_Suffix;
7110
7111 ----------------
7112 -- Add_Suffix --
7113 ----------------
7114
7115 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
7116 begin
7117 Get_Name_String (Chars (E));
7118 Add_Char_To_Name_Buffer (Suffix);
7119 return Name_Find;
7120 end Add_Suffix;
7121
7122 -------------------
7123 -- Remove_Suffix --
7124 -------------------
7125
7126 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
7127 begin
7128 pragma Assert (Has_Suffix (E, Suffix));
7129 Get_Name_String (Chars (E));
7130 Name_Len := Name_Len - 1;
7131 return Name_Find;
7132 end Remove_Suffix;
7133
7134 --------------------------
7135 -- Has_Tagged_Component --
7136 --------------------------
7137
7138 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
7139 Comp : Entity_Id;
7140
7141 begin
7142 if Is_Private_Type (Typ)
7143 and then Present (Underlying_Type (Typ))
7144 then
7145 return Has_Tagged_Component (Underlying_Type (Typ));
7146
7147 elsif Is_Array_Type (Typ) then
7148 return Has_Tagged_Component (Component_Type (Typ));
7149
7150 elsif Is_Tagged_Type (Typ) then
7151 return True;
7152
7153 elsif Is_Record_Type (Typ) then
7154 Comp := First_Component (Typ);
7155 while Present (Comp) loop
7156 if Has_Tagged_Component (Etype (Comp)) then
7157 return True;
7158 end if;
7159
7160 Next_Component (Comp);
7161 end loop;
7162
7163 return False;
7164
7165 else
7166 return False;
7167 end if;
7168 end Has_Tagged_Component;
7169
7170 -------------------------
7171 -- Implementation_Kind --
7172 -------------------------
7173
7174 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
7175 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
7176 Arg : Node_Id;
7177 begin
7178 pragma Assert (Present (Impl_Prag));
7179 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
7180 return Chars (Get_Pragma_Arg (Arg));
7181 end Implementation_Kind;
7182
7183 --------------------------
7184 -- Implements_Interface --
7185 --------------------------
7186
7187 function Implements_Interface
7188 (Typ_Ent : Entity_Id;
7189 Iface_Ent : Entity_Id;
7190 Exclude_Parents : Boolean := False) return Boolean
7191 is
7192 Ifaces_List : Elist_Id;
7193 Elmt : Elmt_Id;
7194 Iface : Entity_Id := Base_Type (Iface_Ent);
7195 Typ : Entity_Id := Base_Type (Typ_Ent);
7196
7197 begin
7198 if Is_Class_Wide_Type (Typ) then
7199 Typ := Root_Type (Typ);
7200 end if;
7201
7202 if not Has_Interfaces (Typ) then
7203 return False;
7204 end if;
7205
7206 if Is_Class_Wide_Type (Iface) then
7207 Iface := Root_Type (Iface);
7208 end if;
7209
7210 Collect_Interfaces (Typ, Ifaces_List);
7211
7212 Elmt := First_Elmt (Ifaces_List);
7213 while Present (Elmt) loop
7214 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
7215 and then Exclude_Parents
7216 then
7217 null;
7218
7219 elsif Node (Elmt) = Iface then
7220 return True;
7221 end if;
7222
7223 Next_Elmt (Elmt);
7224 end loop;
7225
7226 return False;
7227 end Implements_Interface;
7228
7229 -----------------
7230 -- In_Instance --
7231 -----------------
7232
7233 function In_Instance return Boolean is
7234 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
7235 S : Entity_Id;
7236
7237 begin
7238 S := Current_Scope;
7239 while Present (S)
7240 and then S /= Standard_Standard
7241 loop
7242 if (Ekind (S) = E_Function
7243 or else Ekind (S) = E_Package
7244 or else Ekind (S) = E_Procedure)
7245 and then Is_Generic_Instance (S)
7246 then
7247 -- A child instance is always compiled in the context of a parent
7248 -- instance. Nevertheless, the actuals are not analyzed in an
7249 -- instance context. We detect this case by examining the current
7250 -- compilation unit, which must be a child instance, and checking
7251 -- that it is not currently on the scope stack.
7252
7253 if Is_Child_Unit (Curr_Unit)
7254 and then
7255 Nkind (Unit (Cunit (Current_Sem_Unit)))
7256 = N_Package_Instantiation
7257 and then not In_Open_Scopes (Curr_Unit)
7258 then
7259 return False;
7260 else
7261 return True;
7262 end if;
7263 end if;
7264
7265 S := Scope (S);
7266 end loop;
7267
7268 return False;
7269 end In_Instance;
7270
7271 ----------------------
7272 -- In_Instance_Body --
7273 ----------------------
7274
7275 function In_Instance_Body return Boolean is
7276 S : Entity_Id;
7277
7278 begin
7279 S := Current_Scope;
7280 while Present (S)
7281 and then S /= Standard_Standard
7282 loop
7283 if (Ekind (S) = E_Function
7284 or else Ekind (S) = E_Procedure)
7285 and then Is_Generic_Instance (S)
7286 then
7287 return True;
7288
7289 elsif Ekind (S) = E_Package
7290 and then In_Package_Body (S)
7291 and then Is_Generic_Instance (S)
7292 then
7293 return True;
7294 end if;
7295
7296 S := Scope (S);
7297 end loop;
7298
7299 return False;
7300 end In_Instance_Body;
7301
7302 -----------------------------
7303 -- In_Instance_Not_Visible --
7304 -----------------------------
7305
7306 function In_Instance_Not_Visible return Boolean is
7307 S : Entity_Id;
7308
7309 begin
7310 S := Current_Scope;
7311 while Present (S)
7312 and then S /= Standard_Standard
7313 loop
7314 if (Ekind (S) = E_Function
7315 or else Ekind (S) = E_Procedure)
7316 and then Is_Generic_Instance (S)
7317 then
7318 return True;
7319
7320 elsif Ekind (S) = E_Package
7321 and then (In_Package_Body (S) or else In_Private_Part (S))
7322 and then Is_Generic_Instance (S)
7323 then
7324 return True;
7325 end if;
7326
7327 S := Scope (S);
7328 end loop;
7329
7330 return False;
7331 end In_Instance_Not_Visible;
7332
7333 ------------------------------
7334 -- In_Instance_Visible_Part --
7335 ------------------------------
7336
7337 function In_Instance_Visible_Part return Boolean is
7338 S : Entity_Id;
7339
7340 begin
7341 S := Current_Scope;
7342 while Present (S)
7343 and then S /= Standard_Standard
7344 loop
7345 if Ekind (S) = E_Package
7346 and then Is_Generic_Instance (S)
7347 and then not In_Package_Body (S)
7348 and then not In_Private_Part (S)
7349 then
7350 return True;
7351 end if;
7352
7353 S := Scope (S);
7354 end loop;
7355
7356 return False;
7357 end In_Instance_Visible_Part;
7358
7359 ---------------------
7360 -- In_Package_Body --
7361 ---------------------
7362
7363 function In_Package_Body return Boolean is
7364 S : Entity_Id;
7365
7366 begin
7367 S := Current_Scope;
7368 while Present (S)
7369 and then S /= Standard_Standard
7370 loop
7371 if Ekind (S) = E_Package
7372 and then In_Package_Body (S)
7373 then
7374 return True;
7375 else
7376 S := Scope (S);
7377 end if;
7378 end loop;
7379
7380 return False;
7381 end In_Package_Body;
7382
7383 --------------------------------
7384 -- In_Parameter_Specification --
7385 --------------------------------
7386
7387 function In_Parameter_Specification (N : Node_Id) return Boolean is
7388 PN : Node_Id;
7389
7390 begin
7391 PN := Parent (N);
7392 while Present (PN) loop
7393 if Nkind (PN) = N_Parameter_Specification then
7394 return True;
7395 end if;
7396
7397 PN := Parent (PN);
7398 end loop;
7399
7400 return False;
7401 end In_Parameter_Specification;
7402
7403 -------------------------------------
7404 -- In_Reverse_Storage_Order_Object --
7405 -------------------------------------
7406
7407 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
7408 Pref : Node_Id;
7409 Btyp : Entity_Id := Empty;
7410
7411 begin
7412 -- Climb up indexed components
7413
7414 Pref := N;
7415 loop
7416 case Nkind (Pref) is
7417 when N_Selected_Component =>
7418 Pref := Prefix (Pref);
7419 exit;
7420
7421 when N_Indexed_Component =>
7422 Pref := Prefix (Pref);
7423
7424 when others =>
7425 Pref := Empty;
7426 exit;
7427 end case;
7428 end loop;
7429
7430 if Present (Pref) then
7431 Btyp := Base_Type (Etype (Pref));
7432 end if;
7433
7434 return
7435 Present (Btyp)
7436 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
7437 and then Reverse_Storage_Order (Btyp);
7438 end In_Reverse_Storage_Order_Object;
7439
7440 --------------------------------------
7441 -- In_Subprogram_Or_Concurrent_Unit --
7442 --------------------------------------
7443
7444 function In_Subprogram_Or_Concurrent_Unit return Boolean is
7445 E : Entity_Id;
7446 K : Entity_Kind;
7447
7448 begin
7449 -- Use scope chain to check successively outer scopes
7450
7451 E := Current_Scope;
7452 loop
7453 K := Ekind (E);
7454
7455 if K in Subprogram_Kind
7456 or else K in Concurrent_Kind
7457 or else K in Generic_Subprogram_Kind
7458 then
7459 return True;
7460
7461 elsif E = Standard_Standard then
7462 return False;
7463 end if;
7464
7465 E := Scope (E);
7466 end loop;
7467 end In_Subprogram_Or_Concurrent_Unit;
7468
7469 ---------------------
7470 -- In_Visible_Part --
7471 ---------------------
7472
7473 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
7474 begin
7475 return
7476 Is_Package_Or_Generic_Package (Scope_Id)
7477 and then In_Open_Scopes (Scope_Id)
7478 and then not In_Package_Body (Scope_Id)
7479 and then not In_Private_Part (Scope_Id);
7480 end In_Visible_Part;
7481
7482 --------------------------------
7483 -- Incomplete_Or_Private_View --
7484 --------------------------------
7485
7486 function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is
7487 function Inspect_Decls
7488 (Decls : List_Id;
7489 Taft : Boolean := False) return Entity_Id;
7490 -- Check whether a declarative region contains the incomplete or private
7491 -- view of Typ.
7492
7493 -------------------
7494 -- Inspect_Decls --
7495 -------------------
7496
7497 function Inspect_Decls
7498 (Decls : List_Id;
7499 Taft : Boolean := False) return Entity_Id
7500 is
7501 Decl : Node_Id;
7502 Match : Node_Id;
7503
7504 begin
7505 Decl := First (Decls);
7506 while Present (Decl) loop
7507 Match := Empty;
7508
7509 if Taft then
7510 if Nkind (Decl) = N_Incomplete_Type_Declaration then
7511 Match := Defining_Identifier (Decl);
7512 end if;
7513
7514 else
7515 if Nkind_In (Decl, N_Private_Extension_Declaration,
7516 N_Private_Type_Declaration)
7517 then
7518 Match := Defining_Identifier (Decl);
7519 end if;
7520 end if;
7521
7522 if Present (Match)
7523 and then Present (Full_View (Match))
7524 and then Full_View (Match) = Typ
7525 then
7526 return Match;
7527 end if;
7528
7529 Next (Decl);
7530 end loop;
7531
7532 return Empty;
7533 end Inspect_Decls;
7534
7535 -- Local variables
7536
7537 Prev : Entity_Id;
7538
7539 -- Start of processing for Incomplete_Or_Partial_View
7540
7541 begin
7542 -- Incomplete type case
7543
7544 Prev := Current_Entity_In_Scope (Typ);
7545
7546 if Present (Prev)
7547 and then Is_Incomplete_Type (Prev)
7548 and then Present (Full_View (Prev))
7549 and then Full_View (Prev) = Typ
7550 then
7551 return Prev;
7552 end if;
7553
7554 -- Private or Taft amendment type case
7555
7556 declare
7557 Pkg : constant Entity_Id := Scope (Typ);
7558 Pkg_Decl : Node_Id := Pkg;
7559
7560 begin
7561 if Ekind (Pkg) = E_Package then
7562 while Nkind (Pkg_Decl) /= N_Package_Specification loop
7563 Pkg_Decl := Parent (Pkg_Decl);
7564 end loop;
7565
7566 -- It is knows that Typ has a private view, look for it in the
7567 -- visible declarations of the enclosing scope. A special case
7568 -- of this is when the two views have been exchanged - the full
7569 -- appears earlier than the private.
7570
7571 if Has_Private_Declaration (Typ) then
7572 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
7573
7574 -- Exchanged view case, look in the private declarations
7575
7576 if No (Prev) then
7577 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
7578 end if;
7579
7580 return Prev;
7581
7582 -- Otherwise if this is the package body, then Typ is a potential
7583 -- Taft amendment type. The incomplete view should be located in
7584 -- the private declarations of the enclosing scope.
7585
7586 elsif In_Package_Body (Pkg) then
7587 return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
7588 end if;
7589 end if;
7590 end;
7591
7592 -- The type has no incomplete or private view
7593
7594 return Empty;
7595 end Incomplete_Or_Private_View;
7596
7597 ---------------------------------
7598 -- Insert_Explicit_Dereference --
7599 ---------------------------------
7600
7601 procedure Insert_Explicit_Dereference (N : Node_Id) is
7602 New_Prefix : constant Node_Id := Relocate_Node (N);
7603 Ent : Entity_Id := Empty;
7604 Pref : Node_Id;
7605 I : Interp_Index;
7606 It : Interp;
7607 T : Entity_Id;
7608
7609 begin
7610 Save_Interps (N, New_Prefix);
7611
7612 Rewrite (N,
7613 Make_Explicit_Dereference (Sloc (Parent (N)),
7614 Prefix => New_Prefix));
7615
7616 Set_Etype (N, Designated_Type (Etype (New_Prefix)));
7617
7618 if Is_Overloaded (New_Prefix) then
7619
7620 -- The dereference is also overloaded, and its interpretations are
7621 -- the designated types of the interpretations of the original node.
7622
7623 Set_Etype (N, Any_Type);
7624
7625 Get_First_Interp (New_Prefix, I, It);
7626 while Present (It.Nam) loop
7627 T := It.Typ;
7628
7629 if Is_Access_Type (T) then
7630 Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
7631 end if;
7632
7633 Get_Next_Interp (I, It);
7634 end loop;
7635
7636 End_Interp_List;
7637
7638 else
7639 -- Prefix is unambiguous: mark the original prefix (which might
7640 -- Come_From_Source) as a reference, since the new (relocated) one
7641 -- won't be taken into account.
7642
7643 if Is_Entity_Name (New_Prefix) then
7644 Ent := Entity (New_Prefix);
7645 Pref := New_Prefix;
7646
7647 -- For a retrieval of a subcomponent of some composite object,
7648 -- retrieve the ultimate entity if there is one.
7649
7650 elsif Nkind (New_Prefix) = N_Selected_Component
7651 or else Nkind (New_Prefix) = N_Indexed_Component
7652 then
7653 Pref := Prefix (New_Prefix);
7654 while Present (Pref)
7655 and then
7656 (Nkind (Pref) = N_Selected_Component
7657 or else Nkind (Pref) = N_Indexed_Component)
7658 loop
7659 Pref := Prefix (Pref);
7660 end loop;
7661
7662 if Present (Pref) and then Is_Entity_Name (Pref) then
7663 Ent := Entity (Pref);
7664 end if;
7665 end if;
7666
7667 -- Place the reference on the entity node
7668
7669 if Present (Ent) then
7670 Generate_Reference (Ent, Pref);
7671 end if;
7672 end if;
7673 end Insert_Explicit_Dereference;
7674
7675 ------------------------------------------
7676 -- Inspect_Deferred_Constant_Completion --
7677 ------------------------------------------
7678
7679 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
7680 Decl : Node_Id;
7681
7682 begin
7683 Decl := First (Decls);
7684 while Present (Decl) loop
7685
7686 -- Deferred constant signature
7687
7688 if Nkind (Decl) = N_Object_Declaration
7689 and then Constant_Present (Decl)
7690 and then No (Expression (Decl))
7691
7692 -- No need to check internally generated constants
7693
7694 and then Comes_From_Source (Decl)
7695
7696 -- The constant is not completed. A full object declaration or a
7697 -- pragma Import complete a deferred constant.
7698
7699 and then not Has_Completion (Defining_Identifier (Decl))
7700 then
7701 Error_Msg_N
7702 ("constant declaration requires initialization expression",
7703 Defining_Identifier (Decl));
7704 end if;
7705
7706 Decl := Next (Decl);
7707 end loop;
7708 end Inspect_Deferred_Constant_Completion;
7709
7710 -----------------------------
7711 -- Is_Actual_Out_Parameter --
7712 -----------------------------
7713
7714 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
7715 Formal : Entity_Id;
7716 Call : Node_Id;
7717 begin
7718 Find_Actual (N, Formal, Call);
7719 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
7720 end Is_Actual_Out_Parameter;
7721
7722 -------------------------
7723 -- Is_Actual_Parameter --
7724 -------------------------
7725
7726 function Is_Actual_Parameter (N : Node_Id) return Boolean is
7727 PK : constant Node_Kind := Nkind (Parent (N));
7728
7729 begin
7730 case PK is
7731 when N_Parameter_Association =>
7732 return N = Explicit_Actual_Parameter (Parent (N));
7733
7734 when N_Subprogram_Call =>
7735 return Is_List_Member (N)
7736 and then
7737 List_Containing (N) = Parameter_Associations (Parent (N));
7738
7739 when others =>
7740 return False;
7741 end case;
7742 end Is_Actual_Parameter;
7743
7744 --------------------------------
7745 -- Is_Actual_Tagged_Parameter --
7746 --------------------------------
7747
7748 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
7749 Formal : Entity_Id;
7750 Call : Node_Id;
7751 begin
7752 Find_Actual (N, Formal, Call);
7753 return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
7754 end Is_Actual_Tagged_Parameter;
7755
7756 ---------------------
7757 -- Is_Aliased_View --
7758 ---------------------
7759
7760 function Is_Aliased_View (Obj : Node_Id) return Boolean is
7761 E : Entity_Id;
7762
7763 begin
7764 if Is_Entity_Name (Obj) then
7765 E := Entity (Obj);
7766
7767 return
7768 (Is_Object (E)
7769 and then
7770 (Is_Aliased (E)
7771 or else (Present (Renamed_Object (E))
7772 and then Is_Aliased_View (Renamed_Object (E)))))
7773
7774 or else ((Is_Formal (E)
7775 or else Ekind (E) = E_Generic_In_Out_Parameter
7776 or else Ekind (E) = E_Generic_In_Parameter)
7777 and then Is_Tagged_Type (Etype (E)))
7778
7779 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
7780
7781 -- Current instance of type, either directly or as rewritten
7782 -- reference to the current object.
7783
7784 or else (Is_Entity_Name (Original_Node (Obj))
7785 and then Present (Entity (Original_Node (Obj)))
7786 and then Is_Type (Entity (Original_Node (Obj))))
7787
7788 or else (Is_Type (E) and then E = Current_Scope)
7789
7790 or else (Is_Incomplete_Or_Private_Type (E)
7791 and then Full_View (E) = Current_Scope)
7792
7793 -- Ada 2012 AI05-0053: the return object of an extended return
7794 -- statement is aliased if its type is immutably limited.
7795
7796 or else (Is_Return_Object (E)
7797 and then Is_Immutably_Limited_Type (Etype (E)));
7798
7799 elsif Nkind (Obj) = N_Selected_Component then
7800 return Is_Aliased (Entity (Selector_Name (Obj)));
7801
7802 elsif Nkind (Obj) = N_Indexed_Component then
7803 return Has_Aliased_Components (Etype (Prefix (Obj)))
7804 or else
7805 (Is_Access_Type (Etype (Prefix (Obj)))
7806 and then Has_Aliased_Components
7807 (Designated_Type (Etype (Prefix (Obj)))));
7808
7809 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
7810 return Is_Tagged_Type (Etype (Obj))
7811 and then Is_Aliased_View (Expression (Obj));
7812
7813 elsif Nkind (Obj) = N_Explicit_Dereference then
7814 return Nkind (Original_Node (Obj)) /= N_Function_Call;
7815
7816 else
7817 return False;
7818 end if;
7819 end Is_Aliased_View;
7820
7821 -------------------------
7822 -- Is_Ancestor_Package --
7823 -------------------------
7824
7825 function Is_Ancestor_Package
7826 (E1 : Entity_Id;
7827 E2 : Entity_Id) return Boolean
7828 is
7829 Par : Entity_Id;
7830
7831 begin
7832 Par := E2;
7833 while Present (Par)
7834 and then Par /= Standard_Standard
7835 loop
7836 if Par = E1 then
7837 return True;
7838 end if;
7839
7840 Par := Scope (Par);
7841 end loop;
7842
7843 return False;
7844 end Is_Ancestor_Package;
7845
7846 ----------------------
7847 -- Is_Atomic_Object --
7848 ----------------------
7849
7850 function Is_Atomic_Object (N : Node_Id) return Boolean is
7851
7852 function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
7853 -- Determines if given object has atomic components
7854
7855 function Is_Atomic_Prefix (N : Node_Id) return Boolean;
7856 -- If prefix is an implicit dereference, examine designated type
7857
7858 ----------------------
7859 -- Is_Atomic_Prefix --
7860 ----------------------
7861
7862 function Is_Atomic_Prefix (N : Node_Id) return Boolean is
7863 begin
7864 if Is_Access_Type (Etype (N)) then
7865 return
7866 Has_Atomic_Components (Designated_Type (Etype (N)));
7867 else
7868 return Object_Has_Atomic_Components (N);
7869 end if;
7870 end Is_Atomic_Prefix;
7871
7872 ----------------------------------
7873 -- Object_Has_Atomic_Components --
7874 ----------------------------------
7875
7876 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
7877 begin
7878 if Has_Atomic_Components (Etype (N))
7879 or else Is_Atomic (Etype (N))
7880 then
7881 return True;
7882
7883 elsif Is_Entity_Name (N)
7884 and then (Has_Atomic_Components (Entity (N))
7885 or else Is_Atomic (Entity (N)))
7886 then
7887 return True;
7888
7889 elsif Nkind (N) = N_Selected_Component
7890 and then Is_Atomic (Entity (Selector_Name (N)))
7891 then
7892 return True;
7893
7894 elsif Nkind (N) = N_Indexed_Component
7895 or else Nkind (N) = N_Selected_Component
7896 then
7897 return Is_Atomic_Prefix (Prefix (N));
7898
7899 else
7900 return False;
7901 end if;
7902 end Object_Has_Atomic_Components;
7903
7904 -- Start of processing for Is_Atomic_Object
7905
7906 begin
7907 -- Predicate is not relevant to subprograms
7908
7909 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
7910 return False;
7911
7912 elsif Is_Atomic (Etype (N))
7913 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
7914 then
7915 return True;
7916
7917 elsif Nkind (N) = N_Selected_Component
7918 and then Is_Atomic (Entity (Selector_Name (N)))
7919 then
7920 return True;
7921
7922 elsif Nkind (N) = N_Indexed_Component
7923 or else Nkind (N) = N_Selected_Component
7924 then
7925 return Is_Atomic_Prefix (Prefix (N));
7926
7927 else
7928 return False;
7929 end if;
7930 end Is_Atomic_Object;
7931
7932 ------------------------------------
7933 -- Is_Body_Or_Package_Declaration --
7934 ------------------------------------
7935
7936 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is
7937 begin
7938 return Nkind_In (N, N_Entry_Body,
7939 N_Package_Body,
7940 N_Package_Declaration,
7941 N_Protected_Body,
7942 N_Subprogram_Body,
7943 N_Task_Body);
7944 end Is_Body_Or_Package_Declaration;
7945
7946 -----------------------
7947 -- Is_Bounded_String --
7948 -----------------------
7949
7950 function Is_Bounded_String (T : Entity_Id) return Boolean is
7951 Under : constant Entity_Id := Underlying_Type (Root_Type (T));
7952
7953 begin
7954 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
7955 -- Super_String, or one of the [Wide_]Wide_ versions. This will
7956 -- be True for all the Bounded_String types in instances of the
7957 -- Generic_Bounded_Length generics, and for types derived from those.
7958
7959 return Present (Under)
7960 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else
7961 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else
7962 Is_RTE (Root_Type (Under), RO_WW_Super_String));
7963 end Is_Bounded_String;
7964
7965 -----------------------------
7966 -- Is_Concurrent_Interface --
7967 -----------------------------
7968
7969 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
7970 begin
7971 return
7972 Is_Interface (T)
7973 and then
7974 (Is_Protected_Interface (T)
7975 or else Is_Synchronized_Interface (T)
7976 or else Is_Task_Interface (T));
7977 end Is_Concurrent_Interface;
7978
7979 -----------------------
7980 -- Is_Constant_Bound --
7981 -----------------------
7982
7983 function Is_Constant_Bound (Exp : Node_Id) return Boolean is
7984 begin
7985 if Compile_Time_Known_Value (Exp) then
7986 return True;
7987
7988 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
7989 return Is_Constant_Object (Entity (Exp))
7990 or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
7991
7992 elsif Nkind (Exp) in N_Binary_Op then
7993 return Is_Constant_Bound (Left_Opnd (Exp))
7994 and then Is_Constant_Bound (Right_Opnd (Exp))
7995 and then Scope (Entity (Exp)) = Standard_Standard;
7996
7997 else
7998 return False;
7999 end if;
8000 end Is_Constant_Bound;
8001
8002 --------------------------------------
8003 -- Is_Controlling_Limited_Procedure --
8004 --------------------------------------
8005
8006 function Is_Controlling_Limited_Procedure
8007 (Proc_Nam : Entity_Id) return Boolean
8008 is
8009 Param_Typ : Entity_Id := Empty;
8010
8011 begin
8012 if Ekind (Proc_Nam) = E_Procedure
8013 and then Present (Parameter_Specifications (Parent (Proc_Nam)))
8014 then
8015 Param_Typ := Etype (Parameter_Type (First (
8016 Parameter_Specifications (Parent (Proc_Nam)))));
8017
8018 -- In this case where an Itype was created, the procedure call has been
8019 -- rewritten.
8020
8021 elsif Present (Associated_Node_For_Itype (Proc_Nam))
8022 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
8023 and then
8024 Present (Parameter_Associations
8025 (Associated_Node_For_Itype (Proc_Nam)))
8026 then
8027 Param_Typ :=
8028 Etype (First (Parameter_Associations
8029 (Associated_Node_For_Itype (Proc_Nam))));
8030 end if;
8031
8032 if Present (Param_Typ) then
8033 return
8034 Is_Interface (Param_Typ)
8035 and then Is_Limited_Record (Param_Typ);
8036 end if;
8037
8038 return False;
8039 end Is_Controlling_Limited_Procedure;
8040
8041 -----------------------------
8042 -- Is_CPP_Constructor_Call --
8043 -----------------------------
8044
8045 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
8046 begin
8047 return Nkind (N) = N_Function_Call
8048 and then Is_CPP_Class (Etype (Etype (N)))
8049 and then Is_Constructor (Entity (Name (N)))
8050 and then Is_Imported (Entity (Name (N)));
8051 end Is_CPP_Constructor_Call;
8052
8053 -----------------
8054 -- Is_Delegate --
8055 -----------------
8056
8057 function Is_Delegate (T : Entity_Id) return Boolean is
8058 Desig_Type : Entity_Id;
8059
8060 begin
8061 if VM_Target /= CLI_Target then
8062 return False;
8063 end if;
8064
8065 -- Access-to-subprograms are delegates in CIL
8066
8067 if Ekind (T) = E_Access_Subprogram_Type then
8068 return True;
8069 end if;
8070
8071 if Ekind (T) not in Access_Kind then
8072
8073 -- A delegate is a managed pointer. If no designated type is defined
8074 -- it means that it's not a delegate.
8075
8076 return False;
8077 end if;
8078
8079 Desig_Type := Etype (Directly_Designated_Type (T));
8080
8081 if not Is_Tagged_Type (Desig_Type) then
8082 return False;
8083 end if;
8084
8085 -- Test if the type is inherited from [mscorlib]System.Delegate
8086
8087 while Etype (Desig_Type) /= Desig_Type loop
8088 if Chars (Scope (Desig_Type)) /= No_Name
8089 and then Is_Imported (Scope (Desig_Type))
8090 and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
8091 then
8092 return True;
8093 end if;
8094
8095 Desig_Type := Etype (Desig_Type);
8096 end loop;
8097
8098 return False;
8099 end Is_Delegate;
8100
8101 ----------------------------------------------
8102 -- Is_Dependent_Component_Of_Mutable_Object --
8103 ----------------------------------------------
8104
8105 function Is_Dependent_Component_Of_Mutable_Object
8106 (Object : Node_Id) return Boolean
8107 is
8108 P : Node_Id;
8109 Prefix_Type : Entity_Id;
8110 P_Aliased : Boolean := False;
8111 Comp : Entity_Id;
8112
8113 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
8114 -- Returns True if and only if Comp is declared within a variant part
8115
8116 --------------------------------
8117 -- Is_Declared_Within_Variant --
8118 --------------------------------
8119
8120 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
8121 Comp_Decl : constant Node_Id := Parent (Comp);
8122 Comp_List : constant Node_Id := Parent (Comp_Decl);
8123 begin
8124 return Nkind (Parent (Comp_List)) = N_Variant;
8125 end Is_Declared_Within_Variant;
8126
8127 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
8128
8129 begin
8130 if Is_Variable (Object) then
8131
8132 if Nkind (Object) = N_Selected_Component then
8133 P := Prefix (Object);
8134 Prefix_Type := Etype (P);
8135
8136 if Is_Entity_Name (P) then
8137
8138 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
8139 Prefix_Type := Base_Type (Prefix_Type);
8140 end if;
8141
8142 if Is_Aliased (Entity (P)) then
8143 P_Aliased := True;
8144 end if;
8145
8146 -- A discriminant check on a selected component may be expanded
8147 -- into a dereference when removing side-effects. Recover the
8148 -- original node and its type, which may be unconstrained.
8149
8150 elsif Nkind (P) = N_Explicit_Dereference
8151 and then not (Comes_From_Source (P))
8152 then
8153 P := Original_Node (P);
8154 Prefix_Type := Etype (P);
8155
8156 else
8157 -- Check for prefix being an aliased component???
8158
8159 null;
8160
8161 end if;
8162
8163 -- A heap object is constrained by its initial value
8164
8165 -- Ada 2005 (AI-363): Always assume the object could be mutable in
8166 -- the dereferenced case, since the access value might denote an
8167 -- unconstrained aliased object, whereas in Ada 95 the designated
8168 -- object is guaranteed to be constrained. A worst-case assumption
8169 -- has to apply in Ada 2005 because we can't tell at compile time
8170 -- whether the object is "constrained by its initial value"
8171 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
8172 -- semantic rules -- these rules are acknowledged to need fixing).
8173
8174 if Ada_Version < Ada_2005 then
8175 if Is_Access_Type (Prefix_Type)
8176 or else Nkind (P) = N_Explicit_Dereference
8177 then
8178 return False;
8179 end if;
8180
8181 elsif Ada_Version >= Ada_2005 then
8182 if Is_Access_Type (Prefix_Type) then
8183
8184 -- If the access type is pool-specific, and there is no
8185 -- constrained partial view of the designated type, then the
8186 -- designated object is known to be constrained.
8187
8188 if Ekind (Prefix_Type) = E_Access_Type
8189 and then not Object_Type_Has_Constrained_Partial_View
8190 (Typ => Designated_Type (Prefix_Type),
8191 Scop => Current_Scope)
8192 then
8193 return False;
8194
8195 -- Otherwise (general access type, or there is a constrained
8196 -- partial view of the designated type), we need to check
8197 -- based on the designated type.
8198
8199 else
8200 Prefix_Type := Designated_Type (Prefix_Type);
8201 end if;
8202 end if;
8203 end if;
8204
8205 Comp :=
8206 Original_Record_Component (Entity (Selector_Name (Object)));
8207
8208 -- As per AI-0017, the renaming is illegal in a generic body, even
8209 -- if the subtype is indefinite.
8210
8211 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
8212
8213 if not Is_Constrained (Prefix_Type)
8214 and then (not Is_Indefinite_Subtype (Prefix_Type)
8215 or else
8216 (Is_Generic_Type (Prefix_Type)
8217 and then Ekind (Current_Scope) = E_Generic_Package
8218 and then In_Package_Body (Current_Scope)))
8219
8220 and then (Is_Declared_Within_Variant (Comp)
8221 or else Has_Discriminant_Dependent_Constraint (Comp))
8222 and then (not P_Aliased or else Ada_Version >= Ada_2005)
8223 then
8224 return True;
8225
8226 -- If the prefix is of an access type at this point, then we want
8227 -- to return False, rather than calling this function recursively
8228 -- on the access object (which itself might be a discriminant-
8229 -- dependent component of some other object, but that isn't
8230 -- relevant to checking the object passed to us). This avoids
8231 -- issuing wrong errors when compiling with -gnatc, where there
8232 -- can be implicit dereferences that have not been expanded.
8233
8234 elsif Is_Access_Type (Etype (Prefix (Object))) then
8235 return False;
8236
8237 else
8238 return
8239 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
8240 end if;
8241
8242 elsif Nkind (Object) = N_Indexed_Component
8243 or else Nkind (Object) = N_Slice
8244 then
8245 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
8246
8247 -- A type conversion that Is_Variable is a view conversion:
8248 -- go back to the denoted object.
8249
8250 elsif Nkind (Object) = N_Type_Conversion then
8251 return
8252 Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
8253 end if;
8254 end if;
8255
8256 return False;
8257 end Is_Dependent_Component_Of_Mutable_Object;
8258
8259 ---------------------
8260 -- Is_Dereferenced --
8261 ---------------------
8262
8263 function Is_Dereferenced (N : Node_Id) return Boolean is
8264 P : constant Node_Id := Parent (N);
8265 begin
8266 return
8267 (Nkind (P) = N_Selected_Component
8268 or else
8269 Nkind (P) = N_Explicit_Dereference
8270 or else
8271 Nkind (P) = N_Indexed_Component
8272 or else
8273 Nkind (P) = N_Slice)
8274 and then Prefix (P) = N;
8275 end Is_Dereferenced;
8276
8277 ----------------------
8278 -- Is_Descendent_Of --
8279 ----------------------
8280
8281 function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
8282 T : Entity_Id;
8283 Etyp : Entity_Id;
8284
8285 begin
8286 pragma Assert (Nkind (T1) in N_Entity);
8287 pragma Assert (Nkind (T2) in N_Entity);
8288
8289 T := Base_Type (T1);
8290
8291 -- Immediate return if the types match
8292
8293 if T = T2 then
8294 return True;
8295
8296 -- Comment needed here ???
8297
8298 elsif Ekind (T) = E_Class_Wide_Type then
8299 return Etype (T) = T2;
8300
8301 -- All other cases
8302
8303 else
8304 loop
8305 Etyp := Etype (T);
8306
8307 -- Done if we found the type we are looking for
8308
8309 if Etyp = T2 then
8310 return True;
8311
8312 -- Done if no more derivations to check
8313
8314 elsif T = T1
8315 or else T = Etyp
8316 then
8317 return False;
8318
8319 -- Following test catches error cases resulting from prev errors
8320
8321 elsif No (Etyp) then
8322 return False;
8323
8324 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
8325 return False;
8326
8327 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
8328 return False;
8329 end if;
8330
8331 T := Base_Type (Etyp);
8332 end loop;
8333 end if;
8334 end Is_Descendent_Of;
8335
8336 ----------------------------
8337 -- Is_Expression_Function --
8338 ----------------------------
8339
8340 function Is_Expression_Function (Subp : Entity_Id) return Boolean is
8341 Decl : Node_Id;
8342
8343 begin
8344 if Ekind (Subp) /= E_Function then
8345 return False;
8346
8347 else
8348 Decl := Unit_Declaration_Node (Subp);
8349 return Nkind (Decl) = N_Subprogram_Declaration
8350 and then
8351 (Nkind (Original_Node (Decl)) = N_Expression_Function
8352 or else
8353 (Present (Corresponding_Body (Decl))
8354 and then
8355 Nkind (Original_Node
8356 (Unit_Declaration_Node
8357 (Corresponding_Body (Decl)))) =
8358 N_Expression_Function));
8359 end if;
8360 end Is_Expression_Function;
8361
8362 --------------
8363 -- Is_False --
8364 --------------
8365
8366 function Is_False (U : Uint) return Boolean is
8367 begin
8368 return (U = 0);
8369 end Is_False;
8370
8371 ---------------------------
8372 -- Is_Fixed_Model_Number --
8373 ---------------------------
8374
8375 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
8376 S : constant Ureal := Small_Value (T);
8377 M : Urealp.Save_Mark;
8378 R : Boolean;
8379 begin
8380 M := Urealp.Mark;
8381 R := (U = UR_Trunc (U / S) * S);
8382 Urealp.Release (M);
8383 return R;
8384 end Is_Fixed_Model_Number;
8385
8386 -------------------------------
8387 -- Is_Fully_Initialized_Type --
8388 -------------------------------
8389
8390 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
8391 begin
8392 -- In Ada2012, a scalar type with an aspect Default_Value
8393 -- is fully initialized.
8394
8395 if Is_Scalar_Type (Typ) then
8396 return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ);
8397
8398 elsif Is_Access_Type (Typ) then
8399 return True;
8400
8401 elsif Is_Array_Type (Typ) then
8402 if Is_Fully_Initialized_Type (Component_Type (Typ))
8403 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
8404 then
8405 return True;
8406 end if;
8407
8408 -- An interesting case, if we have a constrained type one of whose
8409 -- bounds is known to be null, then there are no elements to be
8410 -- initialized, so all the elements are initialized!
8411
8412 if Is_Constrained (Typ) then
8413 declare
8414 Indx : Node_Id;
8415 Indx_Typ : Entity_Id;
8416 Lbd, Hbd : Node_Id;
8417
8418 begin
8419 Indx := First_Index (Typ);
8420 while Present (Indx) loop
8421 if Etype (Indx) = Any_Type then
8422 return False;
8423
8424 -- If index is a range, use directly
8425
8426 elsif Nkind (Indx) = N_Range then
8427 Lbd := Low_Bound (Indx);
8428 Hbd := High_Bound (Indx);
8429
8430 else
8431 Indx_Typ := Etype (Indx);
8432
8433 if Is_Private_Type (Indx_Typ) then
8434 Indx_Typ := Full_View (Indx_Typ);
8435 end if;
8436
8437 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
8438 return False;
8439 else
8440 Lbd := Type_Low_Bound (Indx_Typ);
8441 Hbd := Type_High_Bound (Indx_Typ);
8442 end if;
8443 end if;
8444
8445 if Compile_Time_Known_Value (Lbd)
8446 and then Compile_Time_Known_Value (Hbd)
8447 then
8448 if Expr_Value (Hbd) < Expr_Value (Lbd) then
8449 return True;
8450 end if;
8451 end if;
8452
8453 Next_Index (Indx);
8454 end loop;
8455 end;
8456 end if;
8457
8458 -- If no null indexes, then type is not fully initialized
8459
8460 return False;
8461
8462 -- Record types
8463
8464 elsif Is_Record_Type (Typ) then
8465 if Has_Discriminants (Typ)
8466 and then
8467 Present (Discriminant_Default_Value (First_Discriminant (Typ)))
8468 and then Is_Fully_Initialized_Variant (Typ)
8469 then
8470 return True;
8471 end if;
8472
8473 -- We consider bounded string types to be fully initialized, because
8474 -- otherwise we get false alarms when the Data component is not
8475 -- default-initialized.
8476
8477 if Is_Bounded_String (Typ) then
8478 return True;
8479 end if;
8480
8481 -- Controlled records are considered to be fully initialized if
8482 -- there is a user defined Initialize routine. This may not be
8483 -- entirely correct, but as the spec notes, we are guessing here
8484 -- what is best from the point of view of issuing warnings.
8485
8486 if Is_Controlled (Typ) then
8487 declare
8488 Utyp : constant Entity_Id := Underlying_Type (Typ);
8489
8490 begin
8491 if Present (Utyp) then
8492 declare
8493 Init : constant Entity_Id :=
8494 (Find_Prim_Op
8495 (Underlying_Type (Typ), Name_Initialize));
8496
8497 begin
8498 if Present (Init)
8499 and then Comes_From_Source (Init)
8500 and then not
8501 Is_Predefined_File_Name
8502 (File_Name (Get_Source_File_Index (Sloc (Init))))
8503 then
8504 return True;
8505
8506 elsif Has_Null_Extension (Typ)
8507 and then
8508 Is_Fully_Initialized_Type
8509 (Etype (Base_Type (Typ)))
8510 then
8511 return True;
8512 end if;
8513 end;
8514 end if;
8515 end;
8516 end if;
8517
8518 -- Otherwise see if all record components are initialized
8519
8520 declare
8521 Ent : Entity_Id;
8522
8523 begin
8524 Ent := First_Entity (Typ);
8525 while Present (Ent) loop
8526 if Ekind (Ent) = E_Component
8527 and then (No (Parent (Ent))
8528 or else No (Expression (Parent (Ent))))
8529 and then not Is_Fully_Initialized_Type (Etype (Ent))
8530
8531 -- Special VM case for tag components, which need to be
8532 -- defined in this case, but are never initialized as VMs
8533 -- are using other dispatching mechanisms. Ignore this
8534 -- uninitialized case. Note that this applies both to the
8535 -- uTag entry and the main vtable pointer (CPP_Class case).
8536
8537 and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
8538 then
8539 return False;
8540 end if;
8541
8542 Next_Entity (Ent);
8543 end loop;
8544 end;
8545
8546 -- No uninitialized components, so type is fully initialized.
8547 -- Note that this catches the case of no components as well.
8548
8549 return True;
8550
8551 elsif Is_Concurrent_Type (Typ) then
8552 return True;
8553
8554 elsif Is_Private_Type (Typ) then
8555 declare
8556 U : constant Entity_Id := Underlying_Type (Typ);
8557
8558 begin
8559 if No (U) then
8560 return False;
8561 else
8562 return Is_Fully_Initialized_Type (U);
8563 end if;
8564 end;
8565
8566 else
8567 return False;
8568 end if;
8569 end Is_Fully_Initialized_Type;
8570
8571 ----------------------------------
8572 -- Is_Fully_Initialized_Variant --
8573 ----------------------------------
8574
8575 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
8576 Loc : constant Source_Ptr := Sloc (Typ);
8577 Constraints : constant List_Id := New_List;
8578 Components : constant Elist_Id := New_Elmt_List;
8579 Comp_Elmt : Elmt_Id;
8580 Comp_Id : Node_Id;
8581 Comp_List : Node_Id;
8582 Discr : Entity_Id;
8583 Discr_Val : Node_Id;
8584
8585 Report_Errors : Boolean;
8586 pragma Warnings (Off, Report_Errors);
8587
8588 begin
8589 if Serious_Errors_Detected > 0 then
8590 return False;
8591 end if;
8592
8593 if Is_Record_Type (Typ)
8594 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
8595 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
8596 then
8597 Comp_List := Component_List (Type_Definition (Parent (Typ)));
8598
8599 Discr := First_Discriminant (Typ);
8600 while Present (Discr) loop
8601 if Nkind (Parent (Discr)) = N_Discriminant_Specification then
8602 Discr_Val := Expression (Parent (Discr));
8603
8604 if Present (Discr_Val)
8605 and then Is_OK_Static_Expression (Discr_Val)
8606 then
8607 Append_To (Constraints,
8608 Make_Component_Association (Loc,
8609 Choices => New_List (New_Occurrence_Of (Discr, Loc)),
8610 Expression => New_Copy (Discr_Val)));
8611 else
8612 return False;
8613 end if;
8614 else
8615 return False;
8616 end if;
8617
8618 Next_Discriminant (Discr);
8619 end loop;
8620
8621 Gather_Components
8622 (Typ => Typ,
8623 Comp_List => Comp_List,
8624 Governed_By => Constraints,
8625 Into => Components,
8626 Report_Errors => Report_Errors);
8627
8628 -- Check that each component present is fully initialized
8629
8630 Comp_Elmt := First_Elmt (Components);
8631 while Present (Comp_Elmt) loop
8632 Comp_Id := Node (Comp_Elmt);
8633
8634 if Ekind (Comp_Id) = E_Component
8635 and then (No (Parent (Comp_Id))
8636 or else No (Expression (Parent (Comp_Id))))
8637 and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
8638 then
8639 return False;
8640 end if;
8641
8642 Next_Elmt (Comp_Elmt);
8643 end loop;
8644
8645 return True;
8646
8647 elsif Is_Private_Type (Typ) then
8648 declare
8649 U : constant Entity_Id := Underlying_Type (Typ);
8650
8651 begin
8652 if No (U) then
8653 return False;
8654 else
8655 return Is_Fully_Initialized_Variant (U);
8656 end if;
8657 end;
8658 else
8659 return False;
8660 end if;
8661 end Is_Fully_Initialized_Variant;
8662
8663 ----------------------------
8664 -- Is_Inherited_Operation --
8665 ----------------------------
8666
8667 function Is_Inherited_Operation (E : Entity_Id) return Boolean is
8668 pragma Assert (Is_Overloadable (E));
8669 Kind : constant Node_Kind := Nkind (Parent (E));
8670 begin
8671 return Kind = N_Full_Type_Declaration
8672 or else Kind = N_Private_Extension_Declaration
8673 or else Kind = N_Subtype_Declaration
8674 or else (Ekind (E) = E_Enumeration_Literal
8675 and then Is_Derived_Type (Etype (E)));
8676 end Is_Inherited_Operation;
8677
8678 -------------------------------------
8679 -- Is_Inherited_Operation_For_Type --
8680 -------------------------------------
8681
8682 function Is_Inherited_Operation_For_Type
8683 (E : Entity_Id;
8684 Typ : Entity_Id) return Boolean
8685 is
8686 begin
8687 -- Check that the operation has been created by the type declaration
8688
8689 return Is_Inherited_Operation (E)
8690 and then Defining_Identifier (Parent (E)) = Typ;
8691 end Is_Inherited_Operation_For_Type;
8692
8693 -----------------
8694 -- Is_Iterator --
8695 -----------------
8696
8697 function Is_Iterator (Typ : Entity_Id) return Boolean is
8698 Ifaces_List : Elist_Id;
8699 Iface_Elmt : Elmt_Id;
8700 Iface : Entity_Id;
8701
8702 begin
8703 if Is_Class_Wide_Type (Typ)
8704 and then
8705 Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator,
8706 Name_Reversible_Iterator)
8707 and then
8708 Is_Predefined_File_Name
8709 (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
8710 then
8711 return True;
8712
8713 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
8714 return False;
8715
8716 else
8717 Collect_Interfaces (Typ, Ifaces_List);
8718
8719 Iface_Elmt := First_Elmt (Ifaces_List);
8720 while Present (Iface_Elmt) loop
8721 Iface := Node (Iface_Elmt);
8722 if Chars (Iface) = Name_Forward_Iterator
8723 and then
8724 Is_Predefined_File_Name
8725 (Unit_File_Name (Get_Source_Unit (Iface)))
8726 then
8727 return True;
8728 end if;
8729
8730 Next_Elmt (Iface_Elmt);
8731 end loop;
8732
8733 return False;
8734 end if;
8735 end Is_Iterator;
8736
8737 ------------
8738 -- Is_LHS --
8739 ------------
8740
8741 -- We seem to have a lot of overlapping functions that do similar things
8742 -- (testing for left hand sides or lvalues???). Anyway, since this one is
8743 -- purely syntactic, it should be in Sem_Aux I would think???
8744
8745 function Is_LHS (N : Node_Id) return Boolean is
8746 P : constant Node_Id := Parent (N);
8747
8748 begin
8749 if Nkind (P) = N_Assignment_Statement then
8750 return Name (P) = N;
8751
8752 elsif
8753 Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
8754 then
8755 return N = Prefix (P) and then Is_LHS (P);
8756
8757 else
8758 return False;
8759 end if;
8760 end Is_LHS;
8761
8762 -----------------------------
8763 -- Is_Library_Level_Entity --
8764 -----------------------------
8765
8766 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
8767 begin
8768 -- The following is a small optimization, and it also properly handles
8769 -- discriminals, which in task bodies might appear in expressions before
8770 -- the corresponding procedure has been created, and which therefore do
8771 -- not have an assigned scope.
8772
8773 if Is_Formal (E) then
8774 return False;
8775 end if;
8776
8777 -- Normal test is simply that the enclosing dynamic scope is Standard
8778
8779 return Enclosing_Dynamic_Scope (E) = Standard_Standard;
8780 end Is_Library_Level_Entity;
8781
8782 --------------------------------
8783 -- Is_Limited_Class_Wide_Type --
8784 --------------------------------
8785
8786 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
8787 begin
8788 return
8789 Is_Class_Wide_Type (Typ)
8790 and then (Is_Limited_Type (Typ) or else From_With_Type (Typ));
8791 end Is_Limited_Class_Wide_Type;
8792
8793 ---------------------------------
8794 -- Is_Local_Variable_Reference --
8795 ---------------------------------
8796
8797 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
8798 begin
8799 if not Is_Entity_Name (Expr) then
8800 return False;
8801
8802 else
8803 declare
8804 Ent : constant Entity_Id := Entity (Expr);
8805 Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
8806 begin
8807 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
8808 return False;
8809 else
8810 return Present (Sub) and then Sub = Current_Subprogram;
8811 end if;
8812 end;
8813 end if;
8814 end Is_Local_Variable_Reference;
8815
8816 -------------------------
8817 -- Is_Object_Reference --
8818 -------------------------
8819
8820 function Is_Object_Reference (N : Node_Id) return Boolean is
8821
8822 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
8823 -- Determine whether N is the name of an internally-generated renaming
8824
8825 --------------------------------------
8826 -- Is_Internally_Generated_Renaming --
8827 --------------------------------------
8828
8829 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
8830 P : Node_Id;
8831
8832 begin
8833 P := N;
8834 while Present (P) loop
8835 if Nkind (P) = N_Object_Renaming_Declaration then
8836 return not Comes_From_Source (P);
8837 elsif Is_List_Member (P) then
8838 return False;
8839 end if;
8840
8841 P := Parent (P);
8842 end loop;
8843
8844 return False;
8845 end Is_Internally_Generated_Renaming;
8846
8847 -- Start of processing for Is_Object_Reference
8848
8849 begin
8850 if Is_Entity_Name (N) then
8851 return Present (Entity (N)) and then Is_Object (Entity (N));
8852
8853 else
8854 case Nkind (N) is
8855 when N_Indexed_Component | N_Slice =>
8856 return
8857 Is_Object_Reference (Prefix (N))
8858 or else Is_Access_Type (Etype (Prefix (N)));
8859
8860 -- In Ada 95, a function call is a constant object; a procedure
8861 -- call is not.
8862
8863 when N_Function_Call =>
8864 return Etype (N) /= Standard_Void_Type;
8865
8866 -- Attributes 'Input and 'Result produce objects
8867
8868 when N_Attribute_Reference =>
8869 return Nam_In (Attribute_Name (N), Name_Input, Name_Result);
8870
8871 when N_Selected_Component =>
8872 return
8873 Is_Object_Reference (Selector_Name (N))
8874 and then
8875 (Is_Object_Reference (Prefix (N))
8876 or else Is_Access_Type (Etype (Prefix (N))));
8877
8878 when N_Explicit_Dereference =>
8879 return True;
8880
8881 -- A view conversion of a tagged object is an object reference
8882
8883 when N_Type_Conversion =>
8884 return Is_Tagged_Type (Etype (Subtype_Mark (N)))
8885 and then Is_Tagged_Type (Etype (Expression (N)))
8886 and then Is_Object_Reference (Expression (N));
8887
8888 -- An unchecked type conversion is considered to be an object if
8889 -- the operand is an object (this construction arises only as a
8890 -- result of expansion activities).
8891
8892 when N_Unchecked_Type_Conversion =>
8893 return True;
8894
8895 -- Allow string literals to act as objects as long as they appear
8896 -- in internally-generated renamings. The expansion of iterators
8897 -- may generate such renamings when the range involves a string
8898 -- literal.
8899
8900 when N_String_Literal =>
8901 return Is_Internally_Generated_Renaming (Parent (N));
8902
8903 -- AI05-0003: In Ada 2012 a qualified expression is a name.
8904 -- This allows disambiguation of function calls and the use
8905 -- of aggregates in more contexts.
8906
8907 when N_Qualified_Expression =>
8908 if Ada_Version < Ada_2012 then
8909 return False;
8910 else
8911 return Is_Object_Reference (Expression (N))
8912 or else Nkind (Expression (N)) = N_Aggregate;
8913 end if;
8914
8915 when others =>
8916 return False;
8917 end case;
8918 end if;
8919 end Is_Object_Reference;
8920
8921 -----------------------------------
8922 -- Is_OK_Variable_For_Out_Formal --
8923 -----------------------------------
8924
8925 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
8926 begin
8927 Note_Possible_Modification (AV, Sure => True);
8928
8929 -- We must reject parenthesized variable names. Comes_From_Source is
8930 -- checked because there are currently cases where the compiler violates
8931 -- this rule (e.g. passing a task object to its controlled Initialize
8932 -- routine). This should be properly documented in sinfo???
8933
8934 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
8935 return False;
8936
8937 -- A variable is always allowed
8938
8939 elsif Is_Variable (AV) then
8940 return True;
8941
8942 -- Unchecked conversions are allowed only if they come from the
8943 -- generated code, which sometimes uses unchecked conversions for out
8944 -- parameters in cases where code generation is unaffected. We tell
8945 -- source unchecked conversions by seeing if they are rewrites of
8946 -- an original Unchecked_Conversion function call, or of an explicit
8947 -- conversion of a function call or an aggregate (as may happen in the
8948 -- expansion of a packed array aggregate).
8949
8950 elsif Nkind (AV) = N_Unchecked_Type_Conversion then
8951 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then
8952 return False;
8953
8954 elsif Comes_From_Source (AV)
8955 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
8956 then
8957 return False;
8958
8959 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
8960 return Is_OK_Variable_For_Out_Formal (Expression (AV));
8961
8962 else
8963 return True;
8964 end if;
8965
8966 -- Normal type conversions are allowed if argument is a variable
8967
8968 elsif Nkind (AV) = N_Type_Conversion then
8969 if Is_Variable (Expression (AV))
8970 and then Paren_Count (Expression (AV)) = 0
8971 then
8972 Note_Possible_Modification (Expression (AV), Sure => True);
8973 return True;
8974
8975 -- We also allow a non-parenthesized expression that raises
8976 -- constraint error if it rewrites what used to be a variable
8977
8978 elsif Raises_Constraint_Error (Expression (AV))
8979 and then Paren_Count (Expression (AV)) = 0
8980 and then Is_Variable (Original_Node (Expression (AV)))
8981 then
8982 return True;
8983
8984 -- Type conversion of something other than a variable
8985
8986 else
8987 return False;
8988 end if;
8989
8990 -- If this node is rewritten, then test the original form, if that is
8991 -- OK, then we consider the rewritten node OK (for example, if the
8992 -- original node is a conversion, then Is_Variable will not be true
8993 -- but we still want to allow the conversion if it converts a variable).
8994
8995 elsif Original_Node (AV) /= AV then
8996
8997 -- In Ada 2012, the explicit dereference may be a rewritten call to a
8998 -- Reference function.
8999
9000 if Ada_Version >= Ada_2012
9001 and then Nkind (Original_Node (AV)) = N_Function_Call
9002 and then
9003 Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
9004 then
9005 return True;
9006
9007 else
9008 return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
9009 end if;
9010
9011 -- All other non-variables are rejected
9012
9013 else
9014 return False;
9015 end if;
9016 end Is_OK_Variable_For_Out_Formal;
9017
9018 -----------------------------------
9019 -- Is_Partially_Initialized_Type --
9020 -----------------------------------
9021
9022 function Is_Partially_Initialized_Type
9023 (Typ : Entity_Id;
9024 Include_Implicit : Boolean := True) return Boolean
9025 is
9026 begin
9027 if Is_Scalar_Type (Typ) then
9028 return False;
9029
9030 elsif Is_Access_Type (Typ) then
9031 return Include_Implicit;
9032
9033 elsif Is_Array_Type (Typ) then
9034
9035 -- If component type is partially initialized, so is array type
9036
9037 if Is_Partially_Initialized_Type
9038 (Component_Type (Typ), Include_Implicit)
9039 then
9040 return True;
9041
9042 -- Otherwise we are only partially initialized if we are fully
9043 -- initialized (this is the empty array case, no point in us
9044 -- duplicating that code here).
9045
9046 else
9047 return Is_Fully_Initialized_Type (Typ);
9048 end if;
9049
9050 elsif Is_Record_Type (Typ) then
9051
9052 -- A discriminated type is always partially initialized if in
9053 -- all mode
9054
9055 if Has_Discriminants (Typ) and then Include_Implicit then
9056 return True;
9057
9058 -- A tagged type is always partially initialized
9059
9060 elsif Is_Tagged_Type (Typ) then
9061 return True;
9062
9063 -- Case of non-discriminated record
9064
9065 else
9066 declare
9067 Ent : Entity_Id;
9068
9069 Component_Present : Boolean := False;
9070 -- Set True if at least one component is present. If no
9071 -- components are present, then record type is fully
9072 -- initialized (another odd case, like the null array).
9073
9074 begin
9075 -- Loop through components
9076
9077 Ent := First_Entity (Typ);
9078 while Present (Ent) loop
9079 if Ekind (Ent) = E_Component then
9080 Component_Present := True;
9081
9082 -- If a component has an initialization expression then
9083 -- the enclosing record type is partially initialized
9084
9085 if Present (Parent (Ent))
9086 and then Present (Expression (Parent (Ent)))
9087 then
9088 return True;
9089
9090 -- If a component is of a type which is itself partially
9091 -- initialized, then the enclosing record type is also.
9092
9093 elsif Is_Partially_Initialized_Type
9094 (Etype (Ent), Include_Implicit)
9095 then
9096 return True;
9097 end if;
9098 end if;
9099
9100 Next_Entity (Ent);
9101 end loop;
9102
9103 -- No initialized components found. If we found any components
9104 -- they were all uninitialized so the result is false.
9105
9106 if Component_Present then
9107 return False;
9108
9109 -- But if we found no components, then all the components are
9110 -- initialized so we consider the type to be initialized.
9111
9112 else
9113 return True;
9114 end if;
9115 end;
9116 end if;
9117
9118 -- Concurrent types are always fully initialized
9119
9120 elsif Is_Concurrent_Type (Typ) then
9121 return True;
9122
9123 -- For a private type, go to underlying type. If there is no underlying
9124 -- type then just assume this partially initialized. Not clear if this
9125 -- can happen in a non-error case, but no harm in testing for this.
9126
9127 elsif Is_Private_Type (Typ) then
9128 declare
9129 U : constant Entity_Id := Underlying_Type (Typ);
9130 begin
9131 if No (U) then
9132 return True;
9133 else
9134 return Is_Partially_Initialized_Type (U, Include_Implicit);
9135 end if;
9136 end;
9137
9138 -- For any other type (are there any?) assume partially initialized
9139
9140 else
9141 return True;
9142 end if;
9143 end Is_Partially_Initialized_Type;
9144
9145 ------------------------------------
9146 -- Is_Potentially_Persistent_Type --
9147 ------------------------------------
9148
9149 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
9150 Comp : Entity_Id;
9151 Indx : Node_Id;
9152
9153 begin
9154 -- For private type, test corresponding full type
9155
9156 if Is_Private_Type (T) then
9157 return Is_Potentially_Persistent_Type (Full_View (T));
9158
9159 -- Scalar types are potentially persistent
9160
9161 elsif Is_Scalar_Type (T) then
9162 return True;
9163
9164 -- Record type is potentially persistent if not tagged and the types of
9165 -- all it components are potentially persistent, and no component has
9166 -- an initialization expression.
9167
9168 elsif Is_Record_Type (T)
9169 and then not Is_Tagged_Type (T)
9170 and then not Is_Partially_Initialized_Type (T)
9171 then
9172 Comp := First_Component (T);
9173 while Present (Comp) loop
9174 if not Is_Potentially_Persistent_Type (Etype (Comp)) then
9175 return False;
9176 else
9177 Next_Entity (Comp);
9178 end if;
9179 end loop;
9180
9181 return True;
9182
9183 -- Array type is potentially persistent if its component type is
9184 -- potentially persistent and if all its constraints are static.
9185
9186 elsif Is_Array_Type (T) then
9187 if not Is_Potentially_Persistent_Type (Component_Type (T)) then
9188 return False;
9189 end if;
9190
9191 Indx := First_Index (T);
9192 while Present (Indx) loop
9193 if not Is_OK_Static_Subtype (Etype (Indx)) then
9194 return False;
9195 else
9196 Next_Index (Indx);
9197 end if;
9198 end loop;
9199
9200 return True;
9201
9202 -- All other types are not potentially persistent
9203
9204 else
9205 return False;
9206 end if;
9207 end Is_Potentially_Persistent_Type;
9208
9209 ---------------------------------
9210 -- Is_Protected_Self_Reference --
9211 ---------------------------------
9212
9213 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
9214
9215 function In_Access_Definition (N : Node_Id) return Boolean;
9216 -- Returns true if N belongs to an access definition
9217
9218 --------------------------
9219 -- In_Access_Definition --
9220 --------------------------
9221
9222 function In_Access_Definition (N : Node_Id) return Boolean is
9223 P : Node_Id;
9224
9225 begin
9226 P := Parent (N);
9227 while Present (P) loop
9228 if Nkind (P) = N_Access_Definition then
9229 return True;
9230 end if;
9231
9232 P := Parent (P);
9233 end loop;
9234
9235 return False;
9236 end In_Access_Definition;
9237
9238 -- Start of processing for Is_Protected_Self_Reference
9239
9240 begin
9241 -- Verify that prefix is analyzed and has the proper form. Note that
9242 -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address,
9243 -- which also produce the address of an entity, do not analyze their
9244 -- prefix because they denote entities that are not necessarily visible.
9245 -- Neither of them can apply to a protected type.
9246
9247 return Ada_Version >= Ada_2005
9248 and then Is_Entity_Name (N)
9249 and then Present (Entity (N))
9250 and then Is_Protected_Type (Entity (N))
9251 and then In_Open_Scopes (Entity (N))
9252 and then not In_Access_Definition (N);
9253 end Is_Protected_Self_Reference;
9254
9255 -----------------------------
9256 -- Is_RCI_Pkg_Spec_Or_Body --
9257 -----------------------------
9258
9259 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
9260
9261 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
9262 -- Return True if the unit of Cunit is an RCI package declaration
9263
9264 ---------------------------
9265 -- Is_RCI_Pkg_Decl_Cunit --
9266 ---------------------------
9267
9268 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
9269 The_Unit : constant Node_Id := Unit (Cunit);
9270
9271 begin
9272 if Nkind (The_Unit) /= N_Package_Declaration then
9273 return False;
9274 end if;
9275
9276 return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
9277 end Is_RCI_Pkg_Decl_Cunit;
9278
9279 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
9280
9281 begin
9282 return Is_RCI_Pkg_Decl_Cunit (Cunit)
9283 or else
9284 (Nkind (Unit (Cunit)) = N_Package_Body
9285 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
9286 end Is_RCI_Pkg_Spec_Or_Body;
9287
9288 -----------------------------------------
9289 -- Is_Remote_Access_To_Class_Wide_Type --
9290 -----------------------------------------
9291
9292 function Is_Remote_Access_To_Class_Wide_Type
9293 (E : Entity_Id) return Boolean
9294 is
9295 begin
9296 -- A remote access to class-wide type is a general access to object type
9297 -- declared in the visible part of a Remote_Types or Remote_Call_
9298 -- Interface unit.
9299
9300 return Ekind (E) = E_General_Access_Type
9301 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
9302 end Is_Remote_Access_To_Class_Wide_Type;
9303
9304 -----------------------------------------
9305 -- Is_Remote_Access_To_Subprogram_Type --
9306 -----------------------------------------
9307
9308 function Is_Remote_Access_To_Subprogram_Type
9309 (E : Entity_Id) return Boolean
9310 is
9311 begin
9312 return (Ekind (E) = E_Access_Subprogram_Type
9313 or else (Ekind (E) = E_Record_Type
9314 and then Present (Corresponding_Remote_Type (E))))
9315 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
9316 end Is_Remote_Access_To_Subprogram_Type;
9317
9318 --------------------
9319 -- Is_Remote_Call --
9320 --------------------
9321
9322 function Is_Remote_Call (N : Node_Id) return Boolean is
9323 begin
9324 if Nkind (N) not in N_Subprogram_Call then
9325
9326 -- An entry call cannot be remote
9327
9328 return False;
9329
9330 elsif Nkind (Name (N)) in N_Has_Entity
9331 and then Is_Remote_Call_Interface (Entity (Name (N)))
9332 then
9333 -- A subprogram declared in the spec of a RCI package is remote
9334
9335 return True;
9336
9337 elsif Nkind (Name (N)) = N_Explicit_Dereference
9338 and then Is_Remote_Access_To_Subprogram_Type
9339 (Etype (Prefix (Name (N))))
9340 then
9341 -- The dereference of a RAS is a remote call
9342
9343 return True;
9344
9345 elsif Present (Controlling_Argument (N))
9346 and then Is_Remote_Access_To_Class_Wide_Type
9347 (Etype (Controlling_Argument (N)))
9348 then
9349 -- Any primitive operation call with a controlling argument of
9350 -- a RACW type is a remote call.
9351
9352 return True;
9353 end if;
9354
9355 -- All other calls are local calls
9356
9357 return False;
9358 end Is_Remote_Call;
9359
9360 ----------------------
9361 -- Is_Renamed_Entry --
9362 ----------------------
9363
9364 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
9365 Orig_Node : Node_Id := Empty;
9366 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
9367
9368 function Is_Entry (Nam : Node_Id) return Boolean;
9369 -- Determine whether Nam is an entry. Traverse selectors if there are
9370 -- nested selected components.
9371
9372 --------------
9373 -- Is_Entry --
9374 --------------
9375
9376 function Is_Entry (Nam : Node_Id) return Boolean is
9377 begin
9378 if Nkind (Nam) = N_Selected_Component then
9379 return Is_Entry (Selector_Name (Nam));
9380 end if;
9381
9382 return Ekind (Entity (Nam)) = E_Entry;
9383 end Is_Entry;
9384
9385 -- Start of processing for Is_Renamed_Entry
9386
9387 begin
9388 if Present (Alias (Proc_Nam)) then
9389 Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
9390 end if;
9391
9392 -- Look for a rewritten subprogram renaming declaration
9393
9394 if Nkind (Subp_Decl) = N_Subprogram_Declaration
9395 and then Present (Original_Node (Subp_Decl))
9396 then
9397 Orig_Node := Original_Node (Subp_Decl);
9398 end if;
9399
9400 -- The rewritten subprogram is actually an entry
9401
9402 if Present (Orig_Node)
9403 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
9404 and then Is_Entry (Name (Orig_Node))
9405 then
9406 return True;
9407 end if;
9408
9409 return False;
9410 end Is_Renamed_Entry;
9411
9412 ----------------------------
9413 -- Is_Reversible_Iterator --
9414 ----------------------------
9415
9416 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
9417 Ifaces_List : Elist_Id;
9418 Iface_Elmt : Elmt_Id;
9419 Iface : Entity_Id;
9420
9421 begin
9422 if Is_Class_Wide_Type (Typ)
9423 and then Chars (Etype (Typ)) = Name_Reversible_Iterator
9424 and then
9425 Is_Predefined_File_Name
9426 (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
9427 then
9428 return True;
9429
9430 elsif not Is_Tagged_Type (Typ)
9431 or else not Is_Derived_Type (Typ)
9432 then
9433 return False;
9434
9435 else
9436 Collect_Interfaces (Typ, Ifaces_List);
9437
9438 Iface_Elmt := First_Elmt (Ifaces_List);
9439 while Present (Iface_Elmt) loop
9440 Iface := Node (Iface_Elmt);
9441 if Chars (Iface) = Name_Reversible_Iterator
9442 and then
9443 Is_Predefined_File_Name
9444 (Unit_File_Name (Get_Source_Unit (Iface)))
9445 then
9446 return True;
9447 end if;
9448
9449 Next_Elmt (Iface_Elmt);
9450 end loop;
9451 end if;
9452
9453 return False;
9454 end Is_Reversible_Iterator;
9455
9456 ----------------------
9457 -- Is_Selector_Name --
9458 ----------------------
9459
9460 function Is_Selector_Name (N : Node_Id) return Boolean is
9461 begin
9462 if not Is_List_Member (N) then
9463 declare
9464 P : constant Node_Id := Parent (N);
9465 K : constant Node_Kind := Nkind (P);
9466 begin
9467 return
9468 (K = N_Expanded_Name or else
9469 K = N_Generic_Association or else
9470 K = N_Parameter_Association or else
9471 K = N_Selected_Component)
9472 and then Selector_Name (P) = N;
9473 end;
9474
9475 else
9476 declare
9477 L : constant List_Id := List_Containing (N);
9478 P : constant Node_Id := Parent (L);
9479 begin
9480 return (Nkind (P) = N_Discriminant_Association
9481 and then Selector_Names (P) = L)
9482 or else
9483 (Nkind (P) = N_Component_Association
9484 and then Choices (P) = L);
9485 end;
9486 end if;
9487 end Is_Selector_Name;
9488
9489 ----------------------------------
9490 -- Is_SPARK_Initialization_Expr --
9491 ----------------------------------
9492
9493 function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
9494 Is_Ok : Boolean;
9495 Expr : Node_Id;
9496 Comp_Assn : Node_Id;
9497 Orig_N : constant Node_Id := Original_Node (N);
9498
9499 begin
9500 Is_Ok := True;
9501
9502 if not Comes_From_Source (Orig_N) then
9503 goto Done;
9504 end if;
9505
9506 pragma Assert (Nkind (Orig_N) in N_Subexpr);
9507
9508 case Nkind (Orig_N) is
9509 when N_Character_Literal |
9510 N_Integer_Literal |
9511 N_Real_Literal |
9512 N_String_Literal =>
9513 null;
9514
9515 when N_Identifier |
9516 N_Expanded_Name =>
9517 if Is_Entity_Name (Orig_N)
9518 and then Present (Entity (Orig_N)) -- needed in some cases
9519 then
9520 case Ekind (Entity (Orig_N)) is
9521 when E_Constant |
9522 E_Enumeration_Literal |
9523 E_Named_Integer |
9524 E_Named_Real =>
9525 null;
9526 when others =>
9527 if Is_Type (Entity (Orig_N)) then
9528 null;
9529 else
9530 Is_Ok := False;
9531 end if;
9532 end case;
9533 end if;
9534
9535 when N_Qualified_Expression |
9536 N_Type_Conversion =>
9537 Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N));
9538
9539 when N_Unary_Op =>
9540 Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
9541
9542 when N_Binary_Op |
9543 N_Short_Circuit |
9544 N_Membership_Test =>
9545 Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
9546 and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
9547
9548 when N_Aggregate |
9549 N_Extension_Aggregate =>
9550 if Nkind (Orig_N) = N_Extension_Aggregate then
9551 Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N));
9552 end if;
9553
9554 Expr := First (Expressions (Orig_N));
9555 while Present (Expr) loop
9556 if not Is_SPARK_Initialization_Expr (Expr) then
9557 Is_Ok := False;
9558 goto Done;
9559 end if;
9560
9561 Next (Expr);
9562 end loop;
9563
9564 Comp_Assn := First (Component_Associations (Orig_N));
9565 while Present (Comp_Assn) loop
9566 Expr := Expression (Comp_Assn);
9567 if Present (Expr) -- needed for box association
9568 and then not Is_SPARK_Initialization_Expr (Expr)
9569 then
9570 Is_Ok := False;
9571 goto Done;
9572 end if;
9573
9574 Next (Comp_Assn);
9575 end loop;
9576
9577 when N_Attribute_Reference =>
9578 if Nkind (Prefix (Orig_N)) in N_Subexpr then
9579 Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N));
9580 end if;
9581
9582 Expr := First (Expressions (Orig_N));
9583 while Present (Expr) loop
9584 if not Is_SPARK_Initialization_Expr (Expr) then
9585 Is_Ok := False;
9586 goto Done;
9587 end if;
9588
9589 Next (Expr);
9590 end loop;
9591
9592 -- Selected components might be expanded named not yet resolved, so
9593 -- default on the safe side. (Eg on sparklex.ads)
9594
9595 when N_Selected_Component =>
9596 null;
9597
9598 when others =>
9599 Is_Ok := False;
9600 end case;
9601
9602 <<Done>>
9603 return Is_Ok;
9604 end Is_SPARK_Initialization_Expr;
9605
9606 -------------------------------
9607 -- Is_SPARK_Object_Reference --
9608 -------------------------------
9609
9610 function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
9611 begin
9612 if Is_Entity_Name (N) then
9613 return Present (Entity (N))
9614 and then
9615 (Ekind_In (Entity (N), E_Constant, E_Variable)
9616 or else Ekind (Entity (N)) in Formal_Kind);
9617
9618 else
9619 case Nkind (N) is
9620 when N_Selected_Component =>
9621 return Is_SPARK_Object_Reference (Prefix (N));
9622
9623 when others =>
9624 return False;
9625 end case;
9626 end if;
9627 end Is_SPARK_Object_Reference;
9628
9629 ------------------
9630 -- Is_Statement --
9631 ------------------
9632
9633 function Is_Statement (N : Node_Id) return Boolean is
9634 begin
9635 return
9636 Nkind (N) in N_Statement_Other_Than_Procedure_Call
9637 or else Nkind (N) = N_Procedure_Call_Statement;
9638 end Is_Statement;
9639
9640 --------------------------------------------------
9641 -- Is_Subprogram_Stub_Without_Prior_Declaration --
9642 --------------------------------------------------
9643
9644 function Is_Subprogram_Stub_Without_Prior_Declaration
9645 (N : Node_Id) return Boolean
9646 is
9647 begin
9648 -- A subprogram stub without prior declaration serves as declaration for
9649 -- the actual subprogram body. As such, it has an attached defining
9650 -- entity of E_[Generic_]Function or E_[Generic_]Procedure.
9651
9652 return Nkind (N) = N_Subprogram_Body_Stub
9653 and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
9654 end Is_Subprogram_Stub_Without_Prior_Declaration;
9655
9656 ---------------------------------
9657 -- Is_Synchronized_Tagged_Type --
9658 ---------------------------------
9659
9660 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
9661 Kind : constant Entity_Kind := Ekind (Base_Type (E));
9662
9663 begin
9664 -- A task or protected type derived from an interface is a tagged type.
9665 -- Such a tagged type is called a synchronized tagged type, as are
9666 -- synchronized interfaces and private extensions whose declaration
9667 -- includes the reserved word synchronized.
9668
9669 return (Is_Tagged_Type (E)
9670 and then (Kind = E_Task_Type
9671 or else Kind = E_Protected_Type))
9672 or else
9673 (Is_Interface (E)
9674 and then Is_Synchronized_Interface (E))
9675 or else
9676 (Ekind (E) = E_Record_Type_With_Private
9677 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
9678 and then (Synchronized_Present (Parent (E))
9679 or else Is_Synchronized_Interface (Etype (E))));
9680 end Is_Synchronized_Tagged_Type;
9681
9682 -----------------
9683 -- Is_Transfer --
9684 -----------------
9685
9686 function Is_Transfer (N : Node_Id) return Boolean is
9687 Kind : constant Node_Kind := Nkind (N);
9688
9689 begin
9690 if Kind = N_Simple_Return_Statement
9691 or else
9692 Kind = N_Extended_Return_Statement
9693 or else
9694 Kind = N_Goto_Statement
9695 or else
9696 Kind = N_Raise_Statement
9697 or else
9698 Kind = N_Requeue_Statement
9699 then
9700 return True;
9701
9702 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
9703 and then No (Condition (N))
9704 then
9705 return True;
9706
9707 elsif Kind = N_Procedure_Call_Statement
9708 and then Is_Entity_Name (Name (N))
9709 and then Present (Entity (Name (N)))
9710 and then No_Return (Entity (Name (N)))
9711 then
9712 return True;
9713
9714 elsif Nkind (Original_Node (N)) = N_Raise_Statement then
9715 return True;
9716
9717 else
9718 return False;
9719 end if;
9720 end Is_Transfer;
9721
9722 -------------
9723 -- Is_True --
9724 -------------
9725
9726 function Is_True (U : Uint) return Boolean is
9727 begin
9728 return (U /= 0);
9729 end Is_True;
9730
9731 -------------------------------
9732 -- Is_Universal_Numeric_Type --
9733 -------------------------------
9734
9735 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
9736 begin
9737 return T = Universal_Integer or else T = Universal_Real;
9738 end Is_Universal_Numeric_Type;
9739
9740 -------------------
9741 -- Is_Value_Type --
9742 -------------------
9743
9744 function Is_Value_Type (T : Entity_Id) return Boolean is
9745 begin
9746 return VM_Target = CLI_Target
9747 and then Nkind (T) in N_Has_Chars
9748 and then Chars (T) /= No_Name
9749 and then Get_Name_String (Chars (T)) = "valuetype";
9750 end Is_Value_Type;
9751
9752 ----------------------------
9753 -- Is_Variable_Size_Array --
9754 ----------------------------
9755
9756 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
9757 Idx : Node_Id;
9758
9759 begin
9760 pragma Assert (Is_Array_Type (E));
9761
9762 -- Check if some index is initialized with a non-constant value
9763
9764 Idx := First_Index (E);
9765 while Present (Idx) loop
9766 if Nkind (Idx) = N_Range then
9767 if not Is_Constant_Bound (Low_Bound (Idx))
9768 or else not Is_Constant_Bound (High_Bound (Idx))
9769 then
9770 return True;
9771 end if;
9772 end if;
9773
9774 Idx := Next_Index (Idx);
9775 end loop;
9776
9777 return False;
9778 end Is_Variable_Size_Array;
9779
9780 -----------------------------
9781 -- Is_Variable_Size_Record --
9782 -----------------------------
9783
9784 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
9785 Comp : Entity_Id;
9786 Comp_Typ : Entity_Id;
9787
9788 begin
9789 pragma Assert (Is_Record_Type (E));
9790
9791 Comp := First_Entity (E);
9792 while Present (Comp) loop
9793 Comp_Typ := Etype (Comp);
9794
9795 -- Recursive call if the record type has discriminants
9796
9797 if Is_Record_Type (Comp_Typ)
9798 and then Has_Discriminants (Comp_Typ)
9799 and then Is_Variable_Size_Record (Comp_Typ)
9800 then
9801 return True;
9802
9803 elsif Is_Array_Type (Comp_Typ)
9804 and then Is_Variable_Size_Array (Comp_Typ)
9805 then
9806 return True;
9807 end if;
9808
9809 Next_Entity (Comp);
9810 end loop;
9811
9812 return False;
9813 end Is_Variable_Size_Record;
9814
9815 ---------------------
9816 -- Is_VMS_Operator --
9817 ---------------------
9818
9819 function Is_VMS_Operator (Op : Entity_Id) return Boolean is
9820 begin
9821 -- The VMS operators are declared in a child of System that is loaded
9822 -- through pragma Extend_System. In some rare cases a program is run
9823 -- with this extension but without indicating that the target is VMS.
9824
9825 return Ekind (Op) = E_Function
9826 and then Is_Intrinsic_Subprogram (Op)
9827 and then
9828 ((Present_System_Aux and then Scope (Op) = System_Aux_Id)
9829 or else
9830 (True_VMS_Target
9831 and then Scope (Scope (Op)) = RTU_Entity (System)));
9832 end Is_VMS_Operator;
9833
9834 -----------------
9835 -- Is_Variable --
9836 -----------------
9837
9838 function Is_Variable
9839 (N : Node_Id;
9840 Use_Original_Node : Boolean := True) return Boolean
9841 is
9842 Orig_Node : Node_Id;
9843
9844 function In_Protected_Function (E : Entity_Id) return Boolean;
9845 -- Within a protected function, the private components of the enclosing
9846 -- protected type are constants. A function nested within a (protected)
9847 -- procedure is not itself protected.
9848
9849 function Is_Variable_Prefix (P : Node_Id) return Boolean;
9850 -- Prefixes can involve implicit dereferences, in which case we must
9851 -- test for the case of a reference of a constant access type, which can
9852 -- can never be a variable.
9853
9854 ---------------------------
9855 -- In_Protected_Function --
9856 ---------------------------
9857
9858 function In_Protected_Function (E : Entity_Id) return Boolean is
9859 Prot : constant Entity_Id := Scope (E);
9860 S : Entity_Id;
9861
9862 begin
9863 if not Is_Protected_Type (Prot) then
9864 return False;
9865 else
9866 S := Current_Scope;
9867 while Present (S) and then S /= Prot loop
9868 if Ekind (S) = E_Function and then Scope (S) = Prot then
9869 return True;
9870 end if;
9871
9872 S := Scope (S);
9873 end loop;
9874
9875 return False;
9876 end if;
9877 end In_Protected_Function;
9878
9879 ------------------------
9880 -- Is_Variable_Prefix --
9881 ------------------------
9882
9883 function Is_Variable_Prefix (P : Node_Id) return Boolean is
9884 begin
9885 if Is_Access_Type (Etype (P)) then
9886 return not Is_Access_Constant (Root_Type (Etype (P)));
9887
9888 -- For the case of an indexed component whose prefix has a packed
9889 -- array type, the prefix has been rewritten into a type conversion.
9890 -- Determine variable-ness from the converted expression.
9891
9892 elsif Nkind (P) = N_Type_Conversion
9893 and then not Comes_From_Source (P)
9894 and then Is_Array_Type (Etype (P))
9895 and then Is_Packed (Etype (P))
9896 then
9897 return Is_Variable (Expression (P));
9898
9899 else
9900 return Is_Variable (P);
9901 end if;
9902 end Is_Variable_Prefix;
9903
9904 -- Start of processing for Is_Variable
9905
9906 begin
9907 -- Check if we perform the test on the original node since this may be a
9908 -- test of syntactic categories which must not be disturbed by whatever
9909 -- rewriting might have occurred. For example, an aggregate, which is
9910 -- certainly NOT a variable, could be turned into a variable by
9911 -- expansion.
9912
9913 if Use_Original_Node then
9914 Orig_Node := Original_Node (N);
9915 else
9916 Orig_Node := N;
9917 end if;
9918
9919 -- Definitely OK if Assignment_OK is set. Since this is something that
9920 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
9921
9922 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
9923 return True;
9924
9925 -- Normally we go to the original node, but there is one exception where
9926 -- we use the rewritten node, namely when it is an explicit dereference.
9927 -- The generated code may rewrite a prefix which is an access type with
9928 -- an explicit dereference. The dereference is a variable, even though
9929 -- the original node may not be (since it could be a constant of the
9930 -- access type).
9931
9932 -- In Ada 2005 we have a further case to consider: the prefix may be a
9933 -- function call given in prefix notation. The original node appears to
9934 -- be a selected component, but we need to examine the call.
9935
9936 elsif Nkind (N) = N_Explicit_Dereference
9937 and then Nkind (Orig_Node) /= N_Explicit_Dereference
9938 and then Present (Etype (Orig_Node))
9939 and then Is_Access_Type (Etype (Orig_Node))
9940 then
9941 -- Note that if the prefix is an explicit dereference that does not
9942 -- come from source, we must check for a rewritten function call in
9943 -- prefixed notation before other forms of rewriting, to prevent a
9944 -- compiler crash.
9945
9946 return
9947 (Nkind (Orig_Node) = N_Function_Call
9948 and then not Is_Access_Constant (Etype (Prefix (N))))
9949 or else
9950 Is_Variable_Prefix (Original_Node (Prefix (N)));
9951
9952 -- in Ada 2012, the dereference may have been added for a type with
9953 -- a declared implicit dereference aspect.
9954
9955 elsif Nkind (N) = N_Explicit_Dereference
9956 and then Present (Etype (Orig_Node))
9957 and then Ada_Version >= Ada_2012
9958 and then Has_Implicit_Dereference (Etype (Orig_Node))
9959 then
9960 return True;
9961
9962 -- A function call is never a variable
9963
9964 elsif Nkind (N) = N_Function_Call then
9965 return False;
9966
9967 -- All remaining checks use the original node
9968
9969 elsif Is_Entity_Name (Orig_Node)
9970 and then Present (Entity (Orig_Node))
9971 then
9972 declare
9973 E : constant Entity_Id := Entity (Orig_Node);
9974 K : constant Entity_Kind := Ekind (E);
9975
9976 begin
9977 return (K = E_Variable
9978 and then Nkind (Parent (E)) /= N_Exception_Handler)
9979 or else (K = E_Component
9980 and then not In_Protected_Function (E))
9981 or else K = E_Out_Parameter
9982 or else K = E_In_Out_Parameter
9983 or else K = E_Generic_In_Out_Parameter
9984
9985 -- Current instance of type
9986
9987 or else (Is_Type (E) and then In_Open_Scopes (E))
9988 or else (Is_Incomplete_Or_Private_Type (E)
9989 and then In_Open_Scopes (Full_View (E)));
9990 end;
9991
9992 else
9993 case Nkind (Orig_Node) is
9994 when N_Indexed_Component | N_Slice =>
9995 return Is_Variable_Prefix (Prefix (Orig_Node));
9996
9997 when N_Selected_Component =>
9998 return Is_Variable_Prefix (Prefix (Orig_Node))
9999 and then Is_Variable (Selector_Name (Orig_Node));
10000
10001 -- For an explicit dereference, the type of the prefix cannot
10002 -- be an access to constant or an access to subprogram.
10003
10004 when N_Explicit_Dereference =>
10005 declare
10006 Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
10007 begin
10008 return Is_Access_Type (Typ)
10009 and then not Is_Access_Constant (Root_Type (Typ))
10010 and then Ekind (Typ) /= E_Access_Subprogram_Type;
10011 end;
10012
10013 -- The type conversion is the case where we do not deal with the
10014 -- context dependent special case of an actual parameter. Thus
10015 -- the type conversion is only considered a variable for the
10016 -- purposes of this routine if the target type is tagged. However,
10017 -- a type conversion is considered to be a variable if it does not
10018 -- come from source (this deals for example with the conversions
10019 -- of expressions to their actual subtypes).
10020
10021 when N_Type_Conversion =>
10022 return Is_Variable (Expression (Orig_Node))
10023 and then
10024 (not Comes_From_Source (Orig_Node)
10025 or else
10026 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
10027 and then
10028 Is_Tagged_Type (Etype (Expression (Orig_Node)))));
10029
10030 -- GNAT allows an unchecked type conversion as a variable. This
10031 -- only affects the generation of internal expanded code, since
10032 -- calls to instantiations of Unchecked_Conversion are never
10033 -- considered variables (since they are function calls).
10034
10035 when N_Unchecked_Type_Conversion =>
10036 return Is_Variable (Expression (Orig_Node));
10037
10038 when others =>
10039 return False;
10040 end case;
10041 end if;
10042 end Is_Variable;
10043
10044 ---------------------------
10045 -- Is_Visibly_Controlled --
10046 ---------------------------
10047
10048 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
10049 Root : constant Entity_Id := Root_Type (T);
10050 begin
10051 return Chars (Scope (Root)) = Name_Finalization
10052 and then Chars (Scope (Scope (Root))) = Name_Ada
10053 and then Scope (Scope (Scope (Root))) = Standard_Standard;
10054 end Is_Visibly_Controlled;
10055
10056 ------------------------
10057 -- Is_Volatile_Object --
10058 ------------------------
10059
10060 function Is_Volatile_Object (N : Node_Id) return Boolean is
10061
10062 function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
10063 -- Determines if given object has volatile components
10064
10065 function Is_Volatile_Prefix (N : Node_Id) return Boolean;
10066 -- If prefix is an implicit dereference, examine designated type
10067
10068 ------------------------
10069 -- Is_Volatile_Prefix --
10070 ------------------------
10071
10072 function Is_Volatile_Prefix (N : Node_Id) return Boolean is
10073 Typ : constant Entity_Id := Etype (N);
10074
10075 begin
10076 if Is_Access_Type (Typ) then
10077 declare
10078 Dtyp : constant Entity_Id := Designated_Type (Typ);
10079
10080 begin
10081 return Is_Volatile (Dtyp)
10082 or else Has_Volatile_Components (Dtyp);
10083 end;
10084
10085 else
10086 return Object_Has_Volatile_Components (N);
10087 end if;
10088 end Is_Volatile_Prefix;
10089
10090 ------------------------------------
10091 -- Object_Has_Volatile_Components --
10092 ------------------------------------
10093
10094 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
10095 Typ : constant Entity_Id := Etype (N);
10096
10097 begin
10098 if Is_Volatile (Typ)
10099 or else Has_Volatile_Components (Typ)
10100 then
10101 return True;
10102
10103 elsif Is_Entity_Name (N)
10104 and then (Has_Volatile_Components (Entity (N))
10105 or else Is_Volatile (Entity (N)))
10106 then
10107 return True;
10108
10109 elsif Nkind (N) = N_Indexed_Component
10110 or else Nkind (N) = N_Selected_Component
10111 then
10112 return Is_Volatile_Prefix (Prefix (N));
10113
10114 else
10115 return False;
10116 end if;
10117 end Object_Has_Volatile_Components;
10118
10119 -- Start of processing for Is_Volatile_Object
10120
10121 begin
10122 if Is_Volatile (Etype (N))
10123 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
10124 then
10125 return True;
10126
10127 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
10128 and then Is_Volatile_Prefix (Prefix (N))
10129 then
10130 return True;
10131
10132 elsif Nkind (N) = N_Selected_Component
10133 and then Is_Volatile (Entity (Selector_Name (N)))
10134 then
10135 return True;
10136
10137 else
10138 return False;
10139 end if;
10140 end Is_Volatile_Object;
10141
10142 ---------------------------
10143 -- Itype_Has_Declaration --
10144 ---------------------------
10145
10146 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
10147 begin
10148 pragma Assert (Is_Itype (Id));
10149 return Present (Parent (Id))
10150 and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
10151 N_Subtype_Declaration)
10152 and then Defining_Entity (Parent (Id)) = Id;
10153 end Itype_Has_Declaration;
10154
10155 -------------------------
10156 -- Kill_Current_Values --
10157 -------------------------
10158
10159 procedure Kill_Current_Values
10160 (Ent : Entity_Id;
10161 Last_Assignment_Only : Boolean := False)
10162 is
10163 begin
10164 -- ??? do we have to worry about clearing cached checks?
10165
10166 if Is_Assignable (Ent) then
10167 Set_Last_Assignment (Ent, Empty);
10168 end if;
10169
10170 if Is_Object (Ent) then
10171 if not Last_Assignment_Only then
10172 Kill_Checks (Ent);
10173 Set_Current_Value (Ent, Empty);
10174
10175 if not Can_Never_Be_Null (Ent) then
10176 Set_Is_Known_Non_Null (Ent, False);
10177 end if;
10178
10179 Set_Is_Known_Null (Ent, False);
10180
10181 -- Reset Is_Known_Valid unless type is always valid, or if we have
10182 -- a loop parameter (loop parameters are always valid, since their
10183 -- bounds are defined by the bounds given in the loop header).
10184
10185 if not Is_Known_Valid (Etype (Ent))
10186 and then Ekind (Ent) /= E_Loop_Parameter
10187 then
10188 Set_Is_Known_Valid (Ent, False);
10189 end if;
10190 end if;
10191 end if;
10192 end Kill_Current_Values;
10193
10194 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
10195 S : Entity_Id;
10196
10197 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
10198 -- Clear current value for entity E and all entities chained to E
10199
10200 ------------------------------------------
10201 -- Kill_Current_Values_For_Entity_Chain --
10202 ------------------------------------------
10203
10204 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
10205 Ent : Entity_Id;
10206 begin
10207 Ent := E;
10208 while Present (Ent) loop
10209 Kill_Current_Values (Ent, Last_Assignment_Only);
10210 Next_Entity (Ent);
10211 end loop;
10212 end Kill_Current_Values_For_Entity_Chain;
10213
10214 -- Start of processing for Kill_Current_Values
10215
10216 begin
10217 -- Kill all saved checks, a special case of killing saved values
10218
10219 if not Last_Assignment_Only then
10220 Kill_All_Checks;
10221 end if;
10222
10223 -- Loop through relevant scopes, which includes the current scope and
10224 -- any parent scopes if the current scope is a block or a package.
10225
10226 S := Current_Scope;
10227 Scope_Loop : loop
10228
10229 -- Clear current values of all entities in current scope
10230
10231 Kill_Current_Values_For_Entity_Chain (First_Entity (S));
10232
10233 -- If scope is a package, also clear current values of all private
10234 -- entities in the scope.
10235
10236 if Is_Package_Or_Generic_Package (S)
10237 or else Is_Concurrent_Type (S)
10238 then
10239 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
10240 end if;
10241
10242 -- If this is a not a subprogram, deal with parents
10243
10244 if not Is_Subprogram (S) then
10245 S := Scope (S);
10246 exit Scope_Loop when S = Standard_Standard;
10247 else
10248 exit Scope_Loop;
10249 end if;
10250 end loop Scope_Loop;
10251 end Kill_Current_Values;
10252
10253 --------------------------
10254 -- Kill_Size_Check_Code --
10255 --------------------------
10256
10257 procedure Kill_Size_Check_Code (E : Entity_Id) is
10258 begin
10259 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
10260 and then Present (Size_Check_Code (E))
10261 then
10262 Remove (Size_Check_Code (E));
10263 Set_Size_Check_Code (E, Empty);
10264 end if;
10265 end Kill_Size_Check_Code;
10266
10267 --------------------------
10268 -- Known_To_Be_Assigned --
10269 --------------------------
10270
10271 function Known_To_Be_Assigned (N : Node_Id) return Boolean is
10272 P : constant Node_Id := Parent (N);
10273
10274 begin
10275 case Nkind (P) is
10276
10277 -- Test left side of assignment
10278
10279 when N_Assignment_Statement =>
10280 return N = Name (P);
10281
10282 -- Function call arguments are never lvalues
10283
10284 when N_Function_Call =>
10285 return False;
10286
10287 -- Positional parameter for procedure or accept call
10288
10289 when N_Procedure_Call_Statement |
10290 N_Accept_Statement
10291 =>
10292 declare
10293 Proc : Entity_Id;
10294 Form : Entity_Id;
10295 Act : Node_Id;
10296
10297 begin
10298 Proc := Get_Subprogram_Entity (P);
10299
10300 if No (Proc) then
10301 return False;
10302 end if;
10303
10304 -- If we are not a list member, something is strange, so
10305 -- be conservative and return False.
10306
10307 if not Is_List_Member (N) then
10308 return False;
10309 end if;
10310
10311 -- We are going to find the right formal by stepping forward
10312 -- through the formals, as we step backwards in the actuals.
10313
10314 Form := First_Formal (Proc);
10315 Act := N;
10316 loop
10317 -- If no formal, something is weird, so be conservative
10318 -- and return False.
10319
10320 if No (Form) then
10321 return False;
10322 end if;
10323
10324 Prev (Act);
10325 exit when No (Act);
10326 Next_Formal (Form);
10327 end loop;
10328
10329 return Ekind (Form) /= E_In_Parameter;
10330 end;
10331
10332 -- Named parameter for procedure or accept call
10333
10334 when N_Parameter_Association =>
10335 declare
10336 Proc : Entity_Id;
10337 Form : Entity_Id;
10338
10339 begin
10340 Proc := Get_Subprogram_Entity (Parent (P));
10341
10342 if No (Proc) then
10343 return False;
10344 end if;
10345
10346 -- Loop through formals to find the one that matches
10347
10348 Form := First_Formal (Proc);
10349 loop
10350 -- If no matching formal, that's peculiar, some kind of
10351 -- previous error, so return False to be conservative.
10352 -- Actually this also happens in legal code in the case
10353 -- where P is a parameter association for an Extra_Formal???
10354
10355 if No (Form) then
10356 return False;
10357 end if;
10358
10359 -- Else test for match
10360
10361 if Chars (Form) = Chars (Selector_Name (P)) then
10362 return Ekind (Form) /= E_In_Parameter;
10363 end if;
10364
10365 Next_Formal (Form);
10366 end loop;
10367 end;
10368
10369 -- Test for appearing in a conversion that itself appears
10370 -- in an lvalue context, since this should be an lvalue.
10371
10372 when N_Type_Conversion =>
10373 return Known_To_Be_Assigned (P);
10374
10375 -- All other references are definitely not known to be modifications
10376
10377 when others =>
10378 return False;
10379
10380 end case;
10381 end Known_To_Be_Assigned;
10382
10383 ---------------------------
10384 -- Last_Source_Statement --
10385 ---------------------------
10386
10387 function Last_Source_Statement (HSS : Node_Id) return Node_Id is
10388 N : Node_Id;
10389
10390 begin
10391 N := Last (Statements (HSS));
10392 while Present (N) loop
10393 exit when Comes_From_Source (N);
10394 Prev (N);
10395 end loop;
10396
10397 return N;
10398 end Last_Source_Statement;
10399
10400 ----------------------------------
10401 -- Matching_Static_Array_Bounds --
10402 ----------------------------------
10403
10404 function Matching_Static_Array_Bounds
10405 (L_Typ : Node_Id;
10406 R_Typ : Node_Id) return Boolean
10407 is
10408 L_Ndims : constant Nat := Number_Dimensions (L_Typ);
10409 R_Ndims : constant Nat := Number_Dimensions (R_Typ);
10410
10411 L_Index : Node_Id;
10412 R_Index : Node_Id;
10413 L_Low : Node_Id;
10414 L_High : Node_Id;
10415 L_Len : Uint;
10416 R_Low : Node_Id;
10417 R_High : Node_Id;
10418 R_Len : Uint;
10419
10420 begin
10421 if L_Ndims /= R_Ndims then
10422 return False;
10423 end if;
10424
10425 -- Unconstrained types do not have static bounds
10426
10427 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
10428 return False;
10429 end if;
10430
10431 -- First treat specially the first dimension, as the lower bound and
10432 -- length of string literals are not stored like those of arrays.
10433
10434 if Ekind (L_Typ) = E_String_Literal_Subtype then
10435 L_Low := String_Literal_Low_Bound (L_Typ);
10436 L_Len := String_Literal_Length (L_Typ);
10437 else
10438 L_Index := First_Index (L_Typ);
10439 Get_Index_Bounds (L_Index, L_Low, L_High);
10440
10441 if Is_OK_Static_Expression (L_Low)
10442 and then Is_OK_Static_Expression (L_High)
10443 then
10444 if Expr_Value (L_High) < Expr_Value (L_Low) then
10445 L_Len := Uint_0;
10446 else
10447 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
10448 end if;
10449 else
10450 return False;
10451 end if;
10452 end if;
10453
10454 if Ekind (R_Typ) = E_String_Literal_Subtype then
10455 R_Low := String_Literal_Low_Bound (R_Typ);
10456 R_Len := String_Literal_Length (R_Typ);
10457 else
10458 R_Index := First_Index (R_Typ);
10459 Get_Index_Bounds (R_Index, R_Low, R_High);
10460
10461 if Is_OK_Static_Expression (R_Low)
10462 and then Is_OK_Static_Expression (R_High)
10463 then
10464 if Expr_Value (R_High) < Expr_Value (R_Low) then
10465 R_Len := Uint_0;
10466 else
10467 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
10468 end if;
10469 else
10470 return False;
10471 end if;
10472 end if;
10473
10474 if Is_OK_Static_Expression (L_Low)
10475 and then Is_OK_Static_Expression (R_Low)
10476 and then Expr_Value (L_Low) = Expr_Value (R_Low)
10477 and then L_Len = R_Len
10478 then
10479 null;
10480 else
10481 return False;
10482 end if;
10483
10484 -- Then treat all other dimensions
10485
10486 for Indx in 2 .. L_Ndims loop
10487 Next (L_Index);
10488 Next (R_Index);
10489
10490 Get_Index_Bounds (L_Index, L_Low, L_High);
10491 Get_Index_Bounds (R_Index, R_Low, R_High);
10492
10493 if Is_OK_Static_Expression (L_Low)
10494 and then Is_OK_Static_Expression (L_High)
10495 and then Is_OK_Static_Expression (R_Low)
10496 and then Is_OK_Static_Expression (R_High)
10497 and then Expr_Value (L_Low) = Expr_Value (R_Low)
10498 and then Expr_Value (L_High) = Expr_Value (R_High)
10499 then
10500 null;
10501 else
10502 return False;
10503 end if;
10504 end loop;
10505
10506 -- If we fall through the loop, all indexes matched
10507
10508 return True;
10509 end Matching_Static_Array_Bounds;
10510
10511 -------------------
10512 -- May_Be_Lvalue --
10513 -------------------
10514
10515 function May_Be_Lvalue (N : Node_Id) return Boolean is
10516 P : constant Node_Id := Parent (N);
10517
10518 begin
10519 case Nkind (P) is
10520
10521 -- Test left side of assignment
10522
10523 when N_Assignment_Statement =>
10524 return N = Name (P);
10525
10526 -- Test prefix of component or attribute. Note that the prefix of an
10527 -- explicit or implicit dereference cannot be an l-value.
10528
10529 when N_Attribute_Reference =>
10530 return N = Prefix (P)
10531 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
10532
10533 -- For an expanded name, the name is an lvalue if the expanded name
10534 -- is an lvalue, but the prefix is never an lvalue, since it is just
10535 -- the scope where the name is found.
10536
10537 when N_Expanded_Name =>
10538 if N = Prefix (P) then
10539 return May_Be_Lvalue (P);
10540 else
10541 return False;
10542 end if;
10543
10544 -- For a selected component A.B, A is certainly an lvalue if A.B is.
10545 -- B is a little interesting, if we have A.B := 3, there is some
10546 -- discussion as to whether B is an lvalue or not, we choose to say
10547 -- it is. Note however that A is not an lvalue if it is of an access
10548 -- type since this is an implicit dereference.
10549
10550 when N_Selected_Component =>
10551 if N = Prefix (P)
10552 and then Present (Etype (N))
10553 and then Is_Access_Type (Etype (N))
10554 then
10555 return False;
10556 else
10557 return May_Be_Lvalue (P);
10558 end if;
10559
10560 -- For an indexed component or slice, the index or slice bounds is
10561 -- never an lvalue. The prefix is an lvalue if the indexed component
10562 -- or slice is an lvalue, except if it is an access type, where we
10563 -- have an implicit dereference.
10564
10565 when N_Indexed_Component | N_Slice =>
10566 if N /= Prefix (P)
10567 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
10568 then
10569 return False;
10570 else
10571 return May_Be_Lvalue (P);
10572 end if;
10573
10574 -- Prefix of a reference is an lvalue if the reference is an lvalue
10575
10576 when N_Reference =>
10577 return May_Be_Lvalue (P);
10578
10579 -- Prefix of explicit dereference is never an lvalue
10580
10581 when N_Explicit_Dereference =>
10582 return False;
10583
10584 -- Positional parameter for subprogram, entry, or accept call.
10585 -- In older versions of Ada function call arguments are never
10586 -- lvalues. In Ada 2012 functions can have in-out parameters.
10587
10588 when N_Subprogram_Call |
10589 N_Entry_Call_Statement |
10590 N_Accept_Statement
10591 =>
10592 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
10593 return False;
10594 end if;
10595
10596 -- The following mechanism is clumsy and fragile. A single flag
10597 -- set in Resolve_Actuals would be preferable ???
10598
10599 declare
10600 Proc : Entity_Id;
10601 Form : Entity_Id;
10602 Act : Node_Id;
10603
10604 begin
10605 Proc := Get_Subprogram_Entity (P);
10606
10607 if No (Proc) then
10608 return True;
10609 end if;
10610
10611 -- If we are not a list member, something is strange, so be
10612 -- conservative and return True.
10613
10614 if not Is_List_Member (N) then
10615 return True;
10616 end if;
10617
10618 -- We are going to find the right formal by stepping forward
10619 -- through the formals, as we step backwards in the actuals.
10620
10621 Form := First_Formal (Proc);
10622 Act := N;
10623 loop
10624 -- If no formal, something is weird, so be conservative and
10625 -- return True.
10626
10627 if No (Form) then
10628 return True;
10629 end if;
10630
10631 Prev (Act);
10632 exit when No (Act);
10633 Next_Formal (Form);
10634 end loop;
10635
10636 return Ekind (Form) /= E_In_Parameter;
10637 end;
10638
10639 -- Named parameter for procedure or accept call
10640
10641 when N_Parameter_Association =>
10642 declare
10643 Proc : Entity_Id;
10644 Form : Entity_Id;
10645
10646 begin
10647 Proc := Get_Subprogram_Entity (Parent (P));
10648
10649 if No (Proc) then
10650 return True;
10651 end if;
10652
10653 -- Loop through formals to find the one that matches
10654
10655 Form := First_Formal (Proc);
10656 loop
10657 -- If no matching formal, that's peculiar, some kind of
10658 -- previous error, so return True to be conservative.
10659 -- Actually happens with legal code for an unresolved call
10660 -- where we may get the wrong homonym???
10661
10662 if No (Form) then
10663 return True;
10664 end if;
10665
10666 -- Else test for match
10667
10668 if Chars (Form) = Chars (Selector_Name (P)) then
10669 return Ekind (Form) /= E_In_Parameter;
10670 end if;
10671
10672 Next_Formal (Form);
10673 end loop;
10674 end;
10675
10676 -- Test for appearing in a conversion that itself appears in an
10677 -- lvalue context, since this should be an lvalue.
10678
10679 when N_Type_Conversion =>
10680 return May_Be_Lvalue (P);
10681
10682 -- Test for appearance in object renaming declaration
10683
10684 when N_Object_Renaming_Declaration =>
10685 return True;
10686
10687 -- All other references are definitely not lvalues
10688
10689 when others =>
10690 return False;
10691
10692 end case;
10693 end May_Be_Lvalue;
10694
10695 -----------------------
10696 -- Mark_Coextensions --
10697 -----------------------
10698
10699 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
10700 Is_Dynamic : Boolean;
10701 -- Indicates whether the context causes nested coextensions to be
10702 -- dynamic or static
10703
10704 function Mark_Allocator (N : Node_Id) return Traverse_Result;
10705 -- Recognize an allocator node and label it as a dynamic coextension
10706
10707 --------------------
10708 -- Mark_Allocator --
10709 --------------------
10710
10711 function Mark_Allocator (N : Node_Id) return Traverse_Result is
10712 begin
10713 if Nkind (N) = N_Allocator then
10714 if Is_Dynamic then
10715 Set_Is_Dynamic_Coextension (N);
10716
10717 -- If the allocator expression is potentially dynamic, it may
10718 -- be expanded out of order and require dynamic allocation
10719 -- anyway, so we treat the coextension itself as dynamic.
10720 -- Potential optimization ???
10721
10722 elsif Nkind (Expression (N)) = N_Qualified_Expression
10723 and then Nkind (Expression (Expression (N))) = N_Op_Concat
10724 then
10725 Set_Is_Dynamic_Coextension (N);
10726 else
10727 Set_Is_Static_Coextension (N);
10728 end if;
10729 end if;
10730
10731 return OK;
10732 end Mark_Allocator;
10733
10734 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
10735
10736 -- Start of processing Mark_Coextensions
10737
10738 begin
10739 case Nkind (Context_Nod) is
10740
10741 -- Comment here ???
10742
10743 when N_Assignment_Statement =>
10744 Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
10745
10746 -- An allocator that is a component of a returned aggregate
10747 -- must be dynamic.
10748
10749 when N_Simple_Return_Statement =>
10750 declare
10751 Expr : constant Node_Id := Expression (Context_Nod);
10752 begin
10753 Is_Dynamic :=
10754 Nkind (Expr) = N_Allocator
10755 or else
10756 (Nkind (Expr) = N_Qualified_Expression
10757 and then Nkind (Expression (Expr)) = N_Aggregate);
10758 end;
10759
10760 -- An alloctor within an object declaration in an extended return
10761 -- statement is of necessity dynamic.
10762
10763 when N_Object_Declaration =>
10764 Is_Dynamic := Nkind (Root_Nod) = N_Allocator
10765 or else
10766 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
10767
10768 -- This routine should not be called for constructs which may not
10769 -- contain coextensions.
10770
10771 when others =>
10772 raise Program_Error;
10773 end case;
10774
10775 Mark_Allocators (Root_Nod);
10776 end Mark_Coextensions;
10777
10778 -----------------
10779 -- Must_Inline --
10780 -----------------
10781
10782 function Must_Inline (Subp : Entity_Id) return Boolean is
10783 begin
10784 return
10785 (Optimization_Level = 0
10786
10787 -- AAMP and VM targets have no support for inlining in the backend.
10788 -- Hence we do as much inlining as possible in the front end.
10789
10790 or else AAMP_On_Target
10791 or else VM_Target /= No_VM)
10792 and then Has_Pragma_Inline (Subp)
10793 and then (Has_Pragma_Inline_Always (Subp) or else Front_End_Inlining);
10794 end Must_Inline;
10795
10796 ----------------------
10797 -- Needs_One_Actual --
10798 ----------------------
10799
10800 function Needs_One_Actual (E : Entity_Id) return Boolean is
10801 Formal : Entity_Id;
10802
10803 begin
10804 -- Ada 2005 or later, and formals present
10805
10806 if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then
10807 Formal := Next_Formal (First_Formal (E));
10808 while Present (Formal) loop
10809 if No (Default_Value (Formal)) then
10810 return False;
10811 end if;
10812
10813 Next_Formal (Formal);
10814 end loop;
10815
10816 return True;
10817
10818 -- Ada 83/95 or no formals
10819
10820 else
10821 return False;
10822 end if;
10823 end Needs_One_Actual;
10824
10825 ------------------------
10826 -- New_Copy_List_Tree --
10827 ------------------------
10828
10829 function New_Copy_List_Tree (List : List_Id) return List_Id is
10830 NL : List_Id;
10831 E : Node_Id;
10832
10833 begin
10834 if List = No_List then
10835 return No_List;
10836
10837 else
10838 NL := New_List;
10839 E := First (List);
10840
10841 while Present (E) loop
10842 Append (New_Copy_Tree (E), NL);
10843 E := Next (E);
10844 end loop;
10845
10846 return NL;
10847 end if;
10848 end New_Copy_List_Tree;
10849
10850 -------------------
10851 -- New_Copy_Tree --
10852 -------------------
10853
10854 use Atree.Unchecked_Access;
10855 use Atree_Private_Part;
10856
10857 -- Our approach here requires a two pass traversal of the tree. The
10858 -- first pass visits all nodes that eventually will be copied looking
10859 -- for defining Itypes. If any defining Itypes are found, then they are
10860 -- copied, and an entry is added to the replacement map. In the second
10861 -- phase, the tree is copied, using the replacement map to replace any
10862 -- Itype references within the copied tree.
10863
10864 -- The following hash tables are used if the Map supplied has more
10865 -- than hash threshold entries to speed up access to the map. If
10866 -- there are fewer entries, then the map is searched sequentially
10867 -- (because setting up a hash table for only a few entries takes
10868 -- more time than it saves.
10869
10870 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
10871 -- Hash function used for hash operations
10872
10873 -------------------
10874 -- New_Copy_Hash --
10875 -------------------
10876
10877 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
10878 begin
10879 return Nat (E) mod (NCT_Header_Num'Last + 1);
10880 end New_Copy_Hash;
10881
10882 ---------------
10883 -- NCT_Assoc --
10884 ---------------
10885
10886 -- The hash table NCT_Assoc associates old entities in the table
10887 -- with their corresponding new entities (i.e. the pairs of entries
10888 -- presented in the original Map argument are Key-Element pairs).
10889
10890 package NCT_Assoc is new Simple_HTable (
10891 Header_Num => NCT_Header_Num,
10892 Element => Entity_Id,
10893 No_Element => Empty,
10894 Key => Entity_Id,
10895 Hash => New_Copy_Hash,
10896 Equal => Types."=");
10897
10898 ---------------------
10899 -- NCT_Itype_Assoc --
10900 ---------------------
10901
10902 -- The hash table NCT_Itype_Assoc contains entries only for those
10903 -- old nodes which have a non-empty Associated_Node_For_Itype set.
10904 -- The key is the associated node, and the element is the new node
10905 -- itself (NOT the associated node for the new node).
10906
10907 package NCT_Itype_Assoc is new Simple_HTable (
10908 Header_Num => NCT_Header_Num,
10909 Element => Entity_Id,
10910 No_Element => Empty,
10911 Key => Entity_Id,
10912 Hash => New_Copy_Hash,
10913 Equal => Types."=");
10914
10915 -- Start of processing for New_Copy_Tree function
10916
10917 function New_Copy_Tree
10918 (Source : Node_Id;
10919 Map : Elist_Id := No_Elist;
10920 New_Sloc : Source_Ptr := No_Location;
10921 New_Scope : Entity_Id := Empty) return Node_Id
10922 is
10923 Actual_Map : Elist_Id := Map;
10924 -- This is the actual map for the copy. It is initialized with the
10925 -- given elements, and then enlarged as required for Itypes that are
10926 -- copied during the first phase of the copy operation. The visit
10927 -- procedures add elements to this map as Itypes are encountered.
10928 -- The reason we cannot use Map directly, is that it may well be
10929 -- (and normally is) initialized to No_Elist, and if we have mapped
10930 -- entities, we have to reset it to point to a real Elist.
10931
10932 function Assoc (N : Node_Or_Entity_Id) return Node_Id;
10933 -- Called during second phase to map entities into their corresponding
10934 -- copies using Actual_Map. If the argument is not an entity, or is not
10935 -- in Actual_Map, then it is returned unchanged.
10936
10937 procedure Build_NCT_Hash_Tables;
10938 -- Builds hash tables (number of elements >= threshold value)
10939
10940 function Copy_Elist_With_Replacement
10941 (Old_Elist : Elist_Id) return Elist_Id;
10942 -- Called during second phase to copy element list doing replacements
10943
10944 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
10945 -- Called during the second phase to process a copied Itype. The actual
10946 -- copy happened during the first phase (so that we could make the entry
10947 -- in the mapping), but we still have to deal with the descendents of
10948 -- the copied Itype and copy them where necessary.
10949
10950 function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
10951 -- Called during second phase to copy list doing replacements
10952
10953 function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
10954 -- Called during second phase to copy node doing replacements
10955
10956 procedure Visit_Elist (E : Elist_Id);
10957 -- Called during first phase to visit all elements of an Elist
10958
10959 procedure Visit_Field (F : Union_Id; N : Node_Id);
10960 -- Visit a single field, recursing to call Visit_Node or Visit_List
10961 -- if the field is a syntactic descendent of the current node (i.e.
10962 -- its parent is Node N).
10963
10964 procedure Visit_Itype (Old_Itype : Entity_Id);
10965 -- Called during first phase to visit subsidiary fields of a defining
10966 -- Itype, and also create a copy and make an entry in the replacement
10967 -- map for the new copy.
10968
10969 procedure Visit_List (L : List_Id);
10970 -- Called during first phase to visit all elements of a List
10971
10972 procedure Visit_Node (N : Node_Or_Entity_Id);
10973 -- Called during first phase to visit a node and all its subtrees
10974
10975 -----------
10976 -- Assoc --
10977 -----------
10978
10979 function Assoc (N : Node_Or_Entity_Id) return Node_Id is
10980 E : Elmt_Id;
10981 Ent : Entity_Id;
10982
10983 begin
10984 if not Has_Extension (N) or else No (Actual_Map) then
10985 return N;
10986
10987 elsif NCT_Hash_Tables_Used then
10988 Ent := NCT_Assoc.Get (Entity_Id (N));
10989
10990 if Present (Ent) then
10991 return Ent;
10992 else
10993 return N;
10994 end if;
10995
10996 -- No hash table used, do serial search
10997
10998 else
10999 E := First_Elmt (Actual_Map);
11000 while Present (E) loop
11001 if Node (E) = N then
11002 return Node (Next_Elmt (E));
11003 else
11004 E := Next_Elmt (Next_Elmt (E));
11005 end if;
11006 end loop;
11007 end if;
11008
11009 return N;
11010 end Assoc;
11011
11012 ---------------------------
11013 -- Build_NCT_Hash_Tables --
11014 ---------------------------
11015
11016 procedure Build_NCT_Hash_Tables is
11017 Elmt : Elmt_Id;
11018 Ent : Entity_Id;
11019 begin
11020 if NCT_Hash_Table_Setup then
11021 NCT_Assoc.Reset;
11022 NCT_Itype_Assoc.Reset;
11023 end if;
11024
11025 Elmt := First_Elmt (Actual_Map);
11026 while Present (Elmt) loop
11027 Ent := Node (Elmt);
11028
11029 -- Get new entity, and associate old and new
11030
11031 Next_Elmt (Elmt);
11032 NCT_Assoc.Set (Ent, Node (Elmt));
11033
11034 if Is_Type (Ent) then
11035 declare
11036 Anode : constant Entity_Id :=
11037 Associated_Node_For_Itype (Ent);
11038
11039 begin
11040 if Present (Anode) then
11041
11042 -- Enter a link between the associated node of the
11043 -- old Itype and the new Itype, for updating later
11044 -- when node is copied.
11045
11046 NCT_Itype_Assoc.Set (Anode, Node (Elmt));
11047 end if;
11048 end;
11049 end if;
11050
11051 Next_Elmt (Elmt);
11052 end loop;
11053
11054 NCT_Hash_Tables_Used := True;
11055 NCT_Hash_Table_Setup := True;
11056 end Build_NCT_Hash_Tables;
11057
11058 ---------------------------------
11059 -- Copy_Elist_With_Replacement --
11060 ---------------------------------
11061
11062 function Copy_Elist_With_Replacement
11063 (Old_Elist : Elist_Id) return Elist_Id
11064 is
11065 M : Elmt_Id;
11066 New_Elist : Elist_Id;
11067
11068 begin
11069 if No (Old_Elist) then
11070 return No_Elist;
11071
11072 else
11073 New_Elist := New_Elmt_List;
11074
11075 M := First_Elmt (Old_Elist);
11076 while Present (M) loop
11077 Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
11078 Next_Elmt (M);
11079 end loop;
11080 end if;
11081
11082 return New_Elist;
11083 end Copy_Elist_With_Replacement;
11084
11085 ---------------------------------
11086 -- Copy_Itype_With_Replacement --
11087 ---------------------------------
11088
11089 -- This routine exactly parallels its phase one analog Visit_Itype,
11090
11091 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
11092 begin
11093 -- Translate Next_Entity, Scope and Etype fields, in case they
11094 -- reference entities that have been mapped into copies.
11095
11096 Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
11097 Set_Etype (New_Itype, Assoc (Etype (New_Itype)));
11098
11099 if Present (New_Scope) then
11100 Set_Scope (New_Itype, New_Scope);
11101 else
11102 Set_Scope (New_Itype, Assoc (Scope (New_Itype)));
11103 end if;
11104
11105 -- Copy referenced fields
11106
11107 if Is_Discrete_Type (New_Itype) then
11108 Set_Scalar_Range (New_Itype,
11109 Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
11110
11111 elsif Has_Discriminants (Base_Type (New_Itype)) then
11112 Set_Discriminant_Constraint (New_Itype,
11113 Copy_Elist_With_Replacement
11114 (Discriminant_Constraint (New_Itype)));
11115
11116 elsif Is_Array_Type (New_Itype) then
11117 if Present (First_Index (New_Itype)) then
11118 Set_First_Index (New_Itype,
11119 First (Copy_List_With_Replacement
11120 (List_Containing (First_Index (New_Itype)))));
11121 end if;
11122
11123 if Is_Packed (New_Itype) then
11124 Set_Packed_Array_Type (New_Itype,
11125 Copy_Node_With_Replacement
11126 (Packed_Array_Type (New_Itype)));
11127 end if;
11128 end if;
11129 end Copy_Itype_With_Replacement;
11130
11131 --------------------------------
11132 -- Copy_List_With_Replacement --
11133 --------------------------------
11134
11135 function Copy_List_With_Replacement
11136 (Old_List : List_Id) return List_Id
11137 is
11138 New_List : List_Id;
11139 E : Node_Id;
11140
11141 begin
11142 if Old_List = No_List then
11143 return No_List;
11144
11145 else
11146 New_List := Empty_List;
11147
11148 E := First (Old_List);
11149 while Present (E) loop
11150 Append (Copy_Node_With_Replacement (E), New_List);
11151 Next (E);
11152 end loop;
11153
11154 return New_List;
11155 end if;
11156 end Copy_List_With_Replacement;
11157
11158 --------------------------------
11159 -- Copy_Node_With_Replacement --
11160 --------------------------------
11161
11162 function Copy_Node_With_Replacement
11163 (Old_Node : Node_Id) return Node_Id
11164 is
11165 New_Node : Node_Id;
11166
11167 procedure Adjust_Named_Associations
11168 (Old_Node : Node_Id;
11169 New_Node : Node_Id);
11170 -- If a call node has named associations, these are chained through
11171 -- the First_Named_Actual, Next_Named_Actual links. These must be
11172 -- propagated separately to the new parameter list, because these
11173 -- are not syntactic fields.
11174
11175 function Copy_Field_With_Replacement
11176 (Field : Union_Id) return Union_Id;
11177 -- Given Field, which is a field of Old_Node, return a copy of it
11178 -- if it is a syntactic field (i.e. its parent is Node), setting
11179 -- the parent of the copy to poit to New_Node. Otherwise returns
11180 -- the field (possibly mapped if it is an entity).
11181
11182 -------------------------------
11183 -- Adjust_Named_Associations --
11184 -------------------------------
11185
11186 procedure Adjust_Named_Associations
11187 (Old_Node : Node_Id;
11188 New_Node : Node_Id)
11189 is
11190 Old_E : Node_Id;
11191 New_E : Node_Id;
11192
11193 Old_Next : Node_Id;
11194 New_Next : Node_Id;
11195
11196 begin
11197 Old_E := First (Parameter_Associations (Old_Node));
11198 New_E := First (Parameter_Associations (New_Node));
11199 while Present (Old_E) loop
11200 if Nkind (Old_E) = N_Parameter_Association
11201 and then Present (Next_Named_Actual (Old_E))
11202 then
11203 if First_Named_Actual (Old_Node)
11204 = Explicit_Actual_Parameter (Old_E)
11205 then
11206 Set_First_Named_Actual
11207 (New_Node, Explicit_Actual_Parameter (New_E));
11208 end if;
11209
11210 -- Now scan parameter list from the beginning,to locate
11211 -- next named actual, which can be out of order.
11212
11213 Old_Next := First (Parameter_Associations (Old_Node));
11214 New_Next := First (Parameter_Associations (New_Node));
11215
11216 while Nkind (Old_Next) /= N_Parameter_Association
11217 or else Explicit_Actual_Parameter (Old_Next)
11218 /= Next_Named_Actual (Old_E)
11219 loop
11220 Next (Old_Next);
11221 Next (New_Next);
11222 end loop;
11223
11224 Set_Next_Named_Actual
11225 (New_E, Explicit_Actual_Parameter (New_Next));
11226 end if;
11227
11228 Next (Old_E);
11229 Next (New_E);
11230 end loop;
11231 end Adjust_Named_Associations;
11232
11233 ---------------------------------
11234 -- Copy_Field_With_Replacement --
11235 ---------------------------------
11236
11237 function Copy_Field_With_Replacement
11238 (Field : Union_Id) return Union_Id
11239 is
11240 begin
11241 if Field = Union_Id (Empty) then
11242 return Field;
11243
11244 elsif Field in Node_Range then
11245 declare
11246 Old_N : constant Node_Id := Node_Id (Field);
11247 New_N : Node_Id;
11248
11249 begin
11250 -- If syntactic field, as indicated by the parent pointer
11251 -- being set, then copy the referenced node recursively.
11252
11253 if Parent (Old_N) = Old_Node then
11254 New_N := Copy_Node_With_Replacement (Old_N);
11255
11256 if New_N /= Old_N then
11257 Set_Parent (New_N, New_Node);
11258 end if;
11259
11260 -- For semantic fields, update possible entity reference
11261 -- from the replacement map.
11262
11263 else
11264 New_N := Assoc (Old_N);
11265 end if;
11266
11267 return Union_Id (New_N);
11268 end;
11269
11270 elsif Field in List_Range then
11271 declare
11272 Old_L : constant List_Id := List_Id (Field);
11273 New_L : List_Id;
11274
11275 begin
11276 -- If syntactic field, as indicated by the parent pointer,
11277 -- then recursively copy the entire referenced list.
11278
11279 if Parent (Old_L) = Old_Node then
11280 New_L := Copy_List_With_Replacement (Old_L);
11281 Set_Parent (New_L, New_Node);
11282
11283 -- For semantic list, just returned unchanged
11284
11285 else
11286 New_L := Old_L;
11287 end if;
11288
11289 return Union_Id (New_L);
11290 end;
11291
11292 -- Anything other than a list or a node is returned unchanged
11293
11294 else
11295 return Field;
11296 end if;
11297 end Copy_Field_With_Replacement;
11298
11299 -- Start of processing for Copy_Node_With_Replacement
11300
11301 begin
11302 if Old_Node <= Empty_Or_Error then
11303 return Old_Node;
11304
11305 elsif Has_Extension (Old_Node) then
11306 return Assoc (Old_Node);
11307
11308 else
11309 New_Node := New_Copy (Old_Node);
11310
11311 -- If the node we are copying is the associated node of a
11312 -- previously copied Itype, then adjust the associated node
11313 -- of the copy of that Itype accordingly.
11314
11315 if Present (Actual_Map) then
11316 declare
11317 E : Elmt_Id;
11318 Ent : Entity_Id;
11319
11320 begin
11321 -- Case of hash table used
11322
11323 if NCT_Hash_Tables_Used then
11324 Ent := NCT_Itype_Assoc.Get (Old_Node);
11325
11326 if Present (Ent) then
11327 Set_Associated_Node_For_Itype (Ent, New_Node);
11328 end if;
11329
11330 -- Case of no hash table used
11331
11332 else
11333 E := First_Elmt (Actual_Map);
11334 while Present (E) loop
11335 if Is_Itype (Node (E))
11336 and then
11337 Old_Node = Associated_Node_For_Itype (Node (E))
11338 then
11339 Set_Associated_Node_For_Itype
11340 (Node (Next_Elmt (E)), New_Node);
11341 end if;
11342
11343 E := Next_Elmt (Next_Elmt (E));
11344 end loop;
11345 end if;
11346 end;
11347 end if;
11348
11349 -- Recursively copy descendents
11350
11351 Set_Field1
11352 (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
11353 Set_Field2
11354 (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
11355 Set_Field3
11356 (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
11357 Set_Field4
11358 (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
11359 Set_Field5
11360 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
11361
11362 -- Adjust Sloc of new node if necessary
11363
11364 if New_Sloc /= No_Location then
11365 Set_Sloc (New_Node, New_Sloc);
11366
11367 -- If we adjust the Sloc, then we are essentially making
11368 -- a completely new node, so the Comes_From_Source flag
11369 -- should be reset to the proper default value.
11370
11371 Nodes.Table (New_Node).Comes_From_Source :=
11372 Default_Node.Comes_From_Source;
11373 end if;
11374
11375 -- If the node is call and has named associations,
11376 -- set the corresponding links in the copy.
11377
11378 if (Nkind (Old_Node) = N_Function_Call
11379 or else Nkind (Old_Node) = N_Entry_Call_Statement
11380 or else
11381 Nkind (Old_Node) = N_Procedure_Call_Statement)
11382 and then Present (First_Named_Actual (Old_Node))
11383 then
11384 Adjust_Named_Associations (Old_Node, New_Node);
11385 end if;
11386
11387 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
11388 -- The replacement mechanism applies to entities, and is not used
11389 -- here. Eventually we may need a more general graph-copying
11390 -- routine. For now, do a sequential search to find desired node.
11391
11392 if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
11393 and then Present (First_Real_Statement (Old_Node))
11394 then
11395 declare
11396 Old_F : constant Node_Id := First_Real_Statement (Old_Node);
11397 N1, N2 : Node_Id;
11398
11399 begin
11400 N1 := First (Statements (Old_Node));
11401 N2 := First (Statements (New_Node));
11402
11403 while N1 /= Old_F loop
11404 Next (N1);
11405 Next (N2);
11406 end loop;
11407
11408 Set_First_Real_Statement (New_Node, N2);
11409 end;
11410 end if;
11411 end if;
11412
11413 -- All done, return copied node
11414
11415 return New_Node;
11416 end Copy_Node_With_Replacement;
11417
11418 -----------------
11419 -- Visit_Elist --
11420 -----------------
11421
11422 procedure Visit_Elist (E : Elist_Id) is
11423 Elmt : Elmt_Id;
11424 begin
11425 if Present (E) then
11426 Elmt := First_Elmt (E);
11427
11428 while Elmt /= No_Elmt loop
11429 Visit_Node (Node (Elmt));
11430 Next_Elmt (Elmt);
11431 end loop;
11432 end if;
11433 end Visit_Elist;
11434
11435 -----------------
11436 -- Visit_Field --
11437 -----------------
11438
11439 procedure Visit_Field (F : Union_Id; N : Node_Id) is
11440 begin
11441 if F = Union_Id (Empty) then
11442 return;
11443
11444 elsif F in Node_Range then
11445
11446 -- Copy node if it is syntactic, i.e. its parent pointer is
11447 -- set to point to the field that referenced it (certain
11448 -- Itypes will also meet this criterion, which is fine, since
11449 -- these are clearly Itypes that do need to be copied, since
11450 -- we are copying their parent.)
11451
11452 if Parent (Node_Id (F)) = N then
11453 Visit_Node (Node_Id (F));
11454 return;
11455
11456 -- Another case, if we are pointing to an Itype, then we want
11457 -- to copy it if its associated node is somewhere in the tree
11458 -- being copied.
11459
11460 -- Note: the exclusion of self-referential copies is just an
11461 -- optimization, since the search of the already copied list
11462 -- would catch it, but it is a common case (Etype pointing
11463 -- to itself for an Itype that is a base type).
11464
11465 elsif Has_Extension (Node_Id (F))
11466 and then Is_Itype (Entity_Id (F))
11467 and then Node_Id (F) /= N
11468 then
11469 declare
11470 P : Node_Id;
11471
11472 begin
11473 P := Associated_Node_For_Itype (Node_Id (F));
11474 while Present (P) loop
11475 if P = Source then
11476 Visit_Node (Node_Id (F));
11477 return;
11478 else
11479 P := Parent (P);
11480 end if;
11481 end loop;
11482
11483 -- An Itype whose parent is not being copied definitely
11484 -- should NOT be copied, since it does not belong in any
11485 -- sense to the copied subtree.
11486
11487 return;
11488 end;
11489 end if;
11490
11491 elsif F in List_Range
11492 and then Parent (List_Id (F)) = N
11493 then
11494 Visit_List (List_Id (F));
11495 return;
11496 end if;
11497 end Visit_Field;
11498
11499 -----------------
11500 -- Visit_Itype --
11501 -----------------
11502
11503 procedure Visit_Itype (Old_Itype : Entity_Id) is
11504 New_Itype : Entity_Id;
11505 E : Elmt_Id;
11506 Ent : Entity_Id;
11507
11508 begin
11509 -- Itypes that describe the designated type of access to subprograms
11510 -- have the structure of subprogram declarations, with signatures,
11511 -- etc. Either we duplicate the signatures completely, or choose to
11512 -- share such itypes, which is fine because their elaboration will
11513 -- have no side effects.
11514
11515 if Ekind (Old_Itype) = E_Subprogram_Type then
11516 return;
11517 end if;
11518
11519 New_Itype := New_Copy (Old_Itype);
11520
11521 -- The new Itype has all the attributes of the old one, and
11522 -- we just copy the contents of the entity. However, the back-end
11523 -- needs different names for debugging purposes, so we create a
11524 -- new internal name for it in all cases.
11525
11526 Set_Chars (New_Itype, New_Internal_Name ('T'));
11527
11528 -- If our associated node is an entity that has already been copied,
11529 -- then set the associated node of the copy to point to the right
11530 -- copy. If we have copied an Itype that is itself the associated
11531 -- node of some previously copied Itype, then we set the right
11532 -- pointer in the other direction.
11533
11534 if Present (Actual_Map) then
11535
11536 -- Case of hash tables used
11537
11538 if NCT_Hash_Tables_Used then
11539
11540 Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
11541
11542 if Present (Ent) then
11543 Set_Associated_Node_For_Itype (New_Itype, Ent);
11544 end if;
11545
11546 Ent := NCT_Itype_Assoc.Get (Old_Itype);
11547 if Present (Ent) then
11548 Set_Associated_Node_For_Itype (Ent, New_Itype);
11549
11550 -- If the hash table has no association for this Itype and
11551 -- its associated node, enter one now.
11552
11553 else
11554 NCT_Itype_Assoc.Set
11555 (Associated_Node_For_Itype (Old_Itype), New_Itype);
11556 end if;
11557
11558 -- Case of hash tables not used
11559
11560 else
11561 E := First_Elmt (Actual_Map);
11562 while Present (E) loop
11563 if Associated_Node_For_Itype (Old_Itype) = Node (E) then
11564 Set_Associated_Node_For_Itype
11565 (New_Itype, Node (Next_Elmt (E)));
11566 end if;
11567
11568 if Is_Type (Node (E))
11569 and then
11570 Old_Itype = Associated_Node_For_Itype (Node (E))
11571 then
11572 Set_Associated_Node_For_Itype
11573 (Node (Next_Elmt (E)), New_Itype);
11574 end if;
11575
11576 E := Next_Elmt (Next_Elmt (E));
11577 end loop;
11578 end if;
11579 end if;
11580
11581 if Present (Freeze_Node (New_Itype)) then
11582 Set_Is_Frozen (New_Itype, False);
11583 Set_Freeze_Node (New_Itype, Empty);
11584 end if;
11585
11586 -- Add new association to map
11587
11588 if No (Actual_Map) then
11589 Actual_Map := New_Elmt_List;
11590 end if;
11591
11592 Append_Elmt (Old_Itype, Actual_Map);
11593 Append_Elmt (New_Itype, Actual_Map);
11594
11595 if NCT_Hash_Tables_Used then
11596 NCT_Assoc.Set (Old_Itype, New_Itype);
11597
11598 else
11599 NCT_Table_Entries := NCT_Table_Entries + 1;
11600
11601 if NCT_Table_Entries > NCT_Hash_Threshold then
11602 Build_NCT_Hash_Tables;
11603 end if;
11604 end if;
11605
11606 -- If a record subtype is simply copied, the entity list will be
11607 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
11608
11609 if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
11610 Set_Cloned_Subtype (New_Itype, Old_Itype);
11611 end if;
11612
11613 -- Visit descendents that eventually get copied
11614
11615 Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
11616
11617 if Is_Discrete_Type (Old_Itype) then
11618 Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
11619
11620 elsif Has_Discriminants (Base_Type (Old_Itype)) then
11621 -- ??? This should involve call to Visit_Field
11622 Visit_Elist (Discriminant_Constraint (Old_Itype));
11623
11624 elsif Is_Array_Type (Old_Itype) then
11625 if Present (First_Index (Old_Itype)) then
11626 Visit_Field (Union_Id (List_Containing
11627 (First_Index (Old_Itype))),
11628 Old_Itype);
11629 end if;
11630
11631 if Is_Packed (Old_Itype) then
11632 Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
11633 Old_Itype);
11634 end if;
11635 end if;
11636 end Visit_Itype;
11637
11638 ----------------
11639 -- Visit_List --
11640 ----------------
11641
11642 procedure Visit_List (L : List_Id) is
11643 N : Node_Id;
11644 begin
11645 if L /= No_List then
11646 N := First (L);
11647
11648 while Present (N) loop
11649 Visit_Node (N);
11650 Next (N);
11651 end loop;
11652 end if;
11653 end Visit_List;
11654
11655 ----------------
11656 -- Visit_Node --
11657 ----------------
11658
11659 procedure Visit_Node (N : Node_Or_Entity_Id) is
11660
11661 -- Start of processing for Visit_Node
11662
11663 begin
11664 -- Handle case of an Itype, which must be copied
11665
11666 if Has_Extension (N)
11667 and then Is_Itype (N)
11668 then
11669 -- Nothing to do if already in the list. This can happen with an
11670 -- Itype entity that appears more than once in the tree.
11671 -- Note that we do not want to visit descendents in this case.
11672
11673 -- Test for already in list when hash table is used
11674
11675 if NCT_Hash_Tables_Used then
11676 if Present (NCT_Assoc.Get (Entity_Id (N))) then
11677 return;
11678 end if;
11679
11680 -- Test for already in list when hash table not used
11681
11682 else
11683 declare
11684 E : Elmt_Id;
11685 begin
11686 if Present (Actual_Map) then
11687 E := First_Elmt (Actual_Map);
11688 while Present (E) loop
11689 if Node (E) = N then
11690 return;
11691 else
11692 E := Next_Elmt (Next_Elmt (E));
11693 end if;
11694 end loop;
11695 end if;
11696 end;
11697 end if;
11698
11699 Visit_Itype (N);
11700 end if;
11701
11702 -- Visit descendents
11703
11704 Visit_Field (Field1 (N), N);
11705 Visit_Field (Field2 (N), N);
11706 Visit_Field (Field3 (N), N);
11707 Visit_Field (Field4 (N), N);
11708 Visit_Field (Field5 (N), N);
11709 end Visit_Node;
11710
11711 -- Start of processing for New_Copy_Tree
11712
11713 begin
11714 Actual_Map := Map;
11715
11716 -- See if we should use hash table
11717
11718 if No (Actual_Map) then
11719 NCT_Hash_Tables_Used := False;
11720
11721 else
11722 declare
11723 Elmt : Elmt_Id;
11724
11725 begin
11726 NCT_Table_Entries := 0;
11727
11728 Elmt := First_Elmt (Actual_Map);
11729 while Present (Elmt) loop
11730 NCT_Table_Entries := NCT_Table_Entries + 1;
11731 Next_Elmt (Elmt);
11732 Next_Elmt (Elmt);
11733 end loop;
11734
11735 if NCT_Table_Entries > NCT_Hash_Threshold then
11736 Build_NCT_Hash_Tables;
11737 else
11738 NCT_Hash_Tables_Used := False;
11739 end if;
11740 end;
11741 end if;
11742
11743 -- Hash table set up if required, now start phase one by visiting
11744 -- top node (we will recursively visit the descendents).
11745
11746 Visit_Node (Source);
11747
11748 -- Now the second phase of the copy can start. First we process
11749 -- all the mapped entities, copying their descendents.
11750
11751 if Present (Actual_Map) then
11752 declare
11753 Elmt : Elmt_Id;
11754 New_Itype : Entity_Id;
11755 begin
11756 Elmt := First_Elmt (Actual_Map);
11757 while Present (Elmt) loop
11758 Next_Elmt (Elmt);
11759 New_Itype := Node (Elmt);
11760 Copy_Itype_With_Replacement (New_Itype);
11761 Next_Elmt (Elmt);
11762 end loop;
11763 end;
11764 end if;
11765
11766 -- Now we can copy the actual tree
11767
11768 return Copy_Node_With_Replacement (Source);
11769 end New_Copy_Tree;
11770
11771 -------------------------
11772 -- New_External_Entity --
11773 -------------------------
11774
11775 function New_External_Entity
11776 (Kind : Entity_Kind;
11777 Scope_Id : Entity_Id;
11778 Sloc_Value : Source_Ptr;
11779 Related_Id : Entity_Id;
11780 Suffix : Character;
11781 Suffix_Index : Nat := 0;
11782 Prefix : Character := ' ') return Entity_Id
11783 is
11784 N : constant Entity_Id :=
11785 Make_Defining_Identifier (Sloc_Value,
11786 New_External_Name
11787 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
11788
11789 begin
11790 Set_Ekind (N, Kind);
11791 Set_Is_Internal (N, True);
11792 Append_Entity (N, Scope_Id);
11793 Set_Public_Status (N);
11794
11795 if Kind in Type_Kind then
11796 Init_Size_Align (N);
11797 end if;
11798
11799 return N;
11800 end New_External_Entity;
11801
11802 -------------------------
11803 -- New_Internal_Entity --
11804 -------------------------
11805
11806 function New_Internal_Entity
11807 (Kind : Entity_Kind;
11808 Scope_Id : Entity_Id;
11809 Sloc_Value : Source_Ptr;
11810 Id_Char : Character) return Entity_Id
11811 is
11812 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
11813
11814 begin
11815 Set_Ekind (N, Kind);
11816 Set_Is_Internal (N, True);
11817 Append_Entity (N, Scope_Id);
11818
11819 if Kind in Type_Kind then
11820 Init_Size_Align (N);
11821 end if;
11822
11823 return N;
11824 end New_Internal_Entity;
11825
11826 -----------------
11827 -- Next_Actual --
11828 -----------------
11829
11830 function Next_Actual (Actual_Id : Node_Id) return Node_Id is
11831 N : Node_Id;
11832
11833 begin
11834 -- If we are pointing at a positional parameter, it is a member of a
11835 -- node list (the list of parameters), and the next parameter is the
11836 -- next node on the list, unless we hit a parameter association, then
11837 -- we shift to using the chain whose head is the First_Named_Actual in
11838 -- the parent, and then is threaded using the Next_Named_Actual of the
11839 -- Parameter_Association. All this fiddling is because the original node
11840 -- list is in the textual call order, and what we need is the
11841 -- declaration order.
11842
11843 if Is_List_Member (Actual_Id) then
11844 N := Next (Actual_Id);
11845
11846 if Nkind (N) = N_Parameter_Association then
11847 return First_Named_Actual (Parent (Actual_Id));
11848 else
11849 return N;
11850 end if;
11851
11852 else
11853 return Next_Named_Actual (Parent (Actual_Id));
11854 end if;
11855 end Next_Actual;
11856
11857 procedure Next_Actual (Actual_Id : in out Node_Id) is
11858 begin
11859 Actual_Id := Next_Actual (Actual_Id);
11860 end Next_Actual;
11861
11862 ---------------------
11863 -- No_Scalar_Parts --
11864 ---------------------
11865
11866 function No_Scalar_Parts (T : Entity_Id) return Boolean is
11867 C : Entity_Id;
11868
11869 begin
11870 if Is_Scalar_Type (T) then
11871 return False;
11872
11873 elsif Is_Array_Type (T) then
11874 return No_Scalar_Parts (Component_Type (T));
11875
11876 elsif Is_Record_Type (T) or else Has_Discriminants (T) then
11877 C := First_Component_Or_Discriminant (T);
11878 while Present (C) loop
11879 if not No_Scalar_Parts (Etype (C)) then
11880 return False;
11881 else
11882 Next_Component_Or_Discriminant (C);
11883 end if;
11884 end loop;
11885 end if;
11886
11887 return True;
11888 end No_Scalar_Parts;
11889
11890 -----------------------
11891 -- Normalize_Actuals --
11892 -----------------------
11893
11894 -- Chain actuals according to formals of subprogram. If there are no named
11895 -- associations, the chain is simply the list of Parameter Associations,
11896 -- since the order is the same as the declaration order. If there are named
11897 -- associations, then the First_Named_Actual field in the N_Function_Call
11898 -- or N_Procedure_Call_Statement node points to the Parameter_Association
11899 -- node for the parameter that comes first in declaration order. The
11900 -- remaining named parameters are then chained in declaration order using
11901 -- Next_Named_Actual.
11902
11903 -- This routine also verifies that the number of actuals is compatible with
11904 -- the number and default values of formals, but performs no type checking
11905 -- (type checking is done by the caller).
11906
11907 -- If the matching succeeds, Success is set to True and the caller proceeds
11908 -- with type-checking. If the match is unsuccessful, then Success is set to
11909 -- False, and the caller attempts a different interpretation, if there is
11910 -- one.
11911
11912 -- If the flag Report is on, the call is not overloaded, and a failure to
11913 -- match can be reported here, rather than in the caller.
11914
11915 procedure Normalize_Actuals
11916 (N : Node_Id;
11917 S : Entity_Id;
11918 Report : Boolean;
11919 Success : out Boolean)
11920 is
11921 Actuals : constant List_Id := Parameter_Associations (N);
11922 Actual : Node_Id := Empty;
11923 Formal : Entity_Id;
11924 Last : Node_Id := Empty;
11925 First_Named : Node_Id := Empty;
11926 Found : Boolean;
11927
11928 Formals_To_Match : Integer := 0;
11929 Actuals_To_Match : Integer := 0;
11930
11931 procedure Chain (A : Node_Id);
11932 -- Add named actual at the proper place in the list, using the
11933 -- Next_Named_Actual link.
11934
11935 function Reporting return Boolean;
11936 -- Determines if an error is to be reported. To report an error, we
11937 -- need Report to be True, and also we do not report errors caused
11938 -- by calls to init procs that occur within other init procs. Such
11939 -- errors must always be cascaded errors, since if all the types are
11940 -- declared correctly, the compiler will certainly build decent calls!
11941
11942 -----------
11943 -- Chain --
11944 -----------
11945
11946 procedure Chain (A : Node_Id) is
11947 begin
11948 if No (Last) then
11949
11950 -- Call node points to first actual in list
11951
11952 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
11953
11954 else
11955 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
11956 end if;
11957
11958 Last := A;
11959 Set_Next_Named_Actual (Last, Empty);
11960 end Chain;
11961
11962 ---------------
11963 -- Reporting --
11964 ---------------
11965
11966 function Reporting return Boolean is
11967 begin
11968 if not Report then
11969 return False;
11970
11971 elsif not Within_Init_Proc then
11972 return True;
11973
11974 elsif Is_Init_Proc (Entity (Name (N))) then
11975 return False;
11976
11977 else
11978 return True;
11979 end if;
11980 end Reporting;
11981
11982 -- Start of processing for Normalize_Actuals
11983
11984 begin
11985 if Is_Access_Type (S) then
11986
11987 -- The name in the call is a function call that returns an access
11988 -- to subprogram. The designated type has the list of formals.
11989
11990 Formal := First_Formal (Designated_Type (S));
11991 else
11992 Formal := First_Formal (S);
11993 end if;
11994
11995 while Present (Formal) loop
11996 Formals_To_Match := Formals_To_Match + 1;
11997 Next_Formal (Formal);
11998 end loop;
11999
12000 -- Find if there is a named association, and verify that no positional
12001 -- associations appear after named ones.
12002
12003 if Present (Actuals) then
12004 Actual := First (Actuals);
12005 end if;
12006
12007 while Present (Actual)
12008 and then Nkind (Actual) /= N_Parameter_Association
12009 loop
12010 Actuals_To_Match := Actuals_To_Match + 1;
12011 Next (Actual);
12012 end loop;
12013
12014 if No (Actual) and Actuals_To_Match = Formals_To_Match then
12015
12016 -- Most common case: positional notation, no defaults
12017
12018 Success := True;
12019 return;
12020
12021 elsif Actuals_To_Match > Formals_To_Match then
12022
12023 -- Too many actuals: will not work
12024
12025 if Reporting then
12026 if Is_Entity_Name (Name (N)) then
12027 Error_Msg_N ("too many arguments in call to&", Name (N));
12028 else
12029 Error_Msg_N ("too many arguments in call", N);
12030 end if;
12031 end if;
12032
12033 Success := False;
12034 return;
12035 end if;
12036
12037 First_Named := Actual;
12038
12039 while Present (Actual) loop
12040 if Nkind (Actual) /= N_Parameter_Association then
12041 Error_Msg_N
12042 ("positional parameters not allowed after named ones", Actual);
12043 Success := False;
12044 return;
12045
12046 else
12047 Actuals_To_Match := Actuals_To_Match + 1;
12048 end if;
12049
12050 Next (Actual);
12051 end loop;
12052
12053 if Present (Actuals) then
12054 Actual := First (Actuals);
12055 end if;
12056
12057 Formal := First_Formal (S);
12058 while Present (Formal) loop
12059
12060 -- Match the formals in order. If the corresponding actual is
12061 -- positional, nothing to do. Else scan the list of named actuals
12062 -- to find the one with the right name.
12063
12064 if Present (Actual)
12065 and then Nkind (Actual) /= N_Parameter_Association
12066 then
12067 Next (Actual);
12068 Actuals_To_Match := Actuals_To_Match - 1;
12069 Formals_To_Match := Formals_To_Match - 1;
12070
12071 else
12072 -- For named parameters, search the list of actuals to find
12073 -- one that matches the next formal name.
12074
12075 Actual := First_Named;
12076 Found := False;
12077 while Present (Actual) loop
12078 if Chars (Selector_Name (Actual)) = Chars (Formal) then
12079 Found := True;
12080 Chain (Actual);
12081 Actuals_To_Match := Actuals_To_Match - 1;
12082 Formals_To_Match := Formals_To_Match - 1;
12083 exit;
12084 end if;
12085
12086 Next (Actual);
12087 end loop;
12088
12089 if not Found then
12090 if Ekind (Formal) /= E_In_Parameter
12091 or else No (Default_Value (Formal))
12092 then
12093 if Reporting then
12094 if (Comes_From_Source (S)
12095 or else Sloc (S) = Standard_Location)
12096 and then Is_Overloadable (S)
12097 then
12098 if No (Actuals)
12099 and then
12100 (Nkind (Parent (N)) = N_Procedure_Call_Statement
12101 or else
12102 (Nkind (Parent (N)) = N_Function_Call
12103 or else
12104 Nkind (Parent (N)) = N_Parameter_Association))
12105 and then Ekind (S) /= E_Function
12106 then
12107 Set_Etype (N, Etype (S));
12108 else
12109 Error_Msg_Name_1 := Chars (S);
12110 Error_Msg_Sloc := Sloc (S);
12111 Error_Msg_NE
12112 ("missing argument for parameter & " &
12113 "in call to % declared #", N, Formal);
12114 end if;
12115
12116 elsif Is_Overloadable (S) then
12117 Error_Msg_Name_1 := Chars (S);
12118
12119 -- Point to type derivation that generated the
12120 -- operation.
12121
12122 Error_Msg_Sloc := Sloc (Parent (S));
12123
12124 Error_Msg_NE
12125 ("missing argument for parameter & " &
12126 "in call to % (inherited) #", N, Formal);
12127
12128 else
12129 Error_Msg_NE
12130 ("missing argument for parameter &", N, Formal);
12131 end if;
12132 end if;
12133
12134 Success := False;
12135 return;
12136
12137 else
12138 Formals_To_Match := Formals_To_Match - 1;
12139 end if;
12140 end if;
12141 end if;
12142
12143 Next_Formal (Formal);
12144 end loop;
12145
12146 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
12147 Success := True;
12148 return;
12149
12150 else
12151 if Reporting then
12152
12153 -- Find some superfluous named actual that did not get
12154 -- attached to the list of associations.
12155
12156 Actual := First (Actuals);
12157 while Present (Actual) loop
12158 if Nkind (Actual) = N_Parameter_Association
12159 and then Actual /= Last
12160 and then No (Next_Named_Actual (Actual))
12161 then
12162 Error_Msg_N ("unmatched actual & in call",
12163 Selector_Name (Actual));
12164 exit;
12165 end if;
12166
12167 Next (Actual);
12168 end loop;
12169 end if;
12170
12171 Success := False;
12172 return;
12173 end if;
12174 end Normalize_Actuals;
12175
12176 --------------------------------
12177 -- Note_Possible_Modification --
12178 --------------------------------
12179
12180 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
12181 Modification_Comes_From_Source : constant Boolean :=
12182 Comes_From_Source (Parent (N));
12183
12184 Ent : Entity_Id;
12185 Exp : Node_Id;
12186
12187 begin
12188 -- Loop to find referenced entity, if there is one
12189
12190 Exp := N;
12191 loop
12192 <<Continue>>
12193 Ent := Empty;
12194
12195 if Is_Entity_Name (Exp) then
12196 Ent := Entity (Exp);
12197
12198 -- If the entity is missing, it is an undeclared identifier,
12199 -- and there is nothing to annotate.
12200
12201 if No (Ent) then
12202 return;
12203 end if;
12204
12205 elsif Nkind (Exp) = N_Explicit_Dereference then
12206 declare
12207 P : constant Node_Id := Prefix (Exp);
12208
12209 begin
12210 -- In formal verification mode, keep track of all reads and
12211 -- writes through explicit dereferences.
12212
12213 if SPARK_Mode then
12214 SPARK_Specific.Generate_Dereference (N, 'm');
12215 end if;
12216
12217 if Nkind (P) = N_Selected_Component
12218 and then Present (
12219 Entry_Formal (Entity (Selector_Name (P))))
12220 then
12221 -- Case of a reference to an entry formal
12222
12223 Ent := Entry_Formal (Entity (Selector_Name (P)));
12224
12225 elsif Nkind (P) = N_Identifier
12226 and then Nkind (Parent (Entity (P))) = N_Object_Declaration
12227 and then Present (Expression (Parent (Entity (P))))
12228 and then Nkind (Expression (Parent (Entity (P))))
12229 = N_Reference
12230 then
12231 -- Case of a reference to a value on which side effects have
12232 -- been removed.
12233
12234 Exp := Prefix (Expression (Parent (Entity (P))));
12235 goto Continue;
12236
12237 else
12238 return;
12239
12240 end if;
12241 end;
12242
12243 elsif Nkind (Exp) = N_Type_Conversion
12244 or else Nkind (Exp) = N_Unchecked_Type_Conversion
12245 then
12246 Exp := Expression (Exp);
12247 goto Continue;
12248
12249 elsif Nkind (Exp) = N_Slice
12250 or else Nkind (Exp) = N_Indexed_Component
12251 or else Nkind (Exp) = N_Selected_Component
12252 then
12253 Exp := Prefix (Exp);
12254 goto Continue;
12255
12256 else
12257 return;
12258 end if;
12259
12260 -- Now look for entity being referenced
12261
12262 if Present (Ent) then
12263 if Is_Object (Ent) then
12264 if Comes_From_Source (Exp)
12265 or else Modification_Comes_From_Source
12266 then
12267 -- Give warning if pragma unmodified given and we are
12268 -- sure this is a modification.
12269
12270 if Has_Pragma_Unmodified (Ent) and then Sure then
12271 Error_Msg_NE
12272 ("??pragma Unmodified given for &!", N, Ent);
12273 end if;
12274
12275 Set_Never_Set_In_Source (Ent, False);
12276 end if;
12277
12278 Set_Is_True_Constant (Ent, False);
12279 Set_Current_Value (Ent, Empty);
12280 Set_Is_Known_Null (Ent, False);
12281
12282 if not Can_Never_Be_Null (Ent) then
12283 Set_Is_Known_Non_Null (Ent, False);
12284 end if;
12285
12286 -- Follow renaming chain
12287
12288 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
12289 and then Present (Renamed_Object (Ent))
12290 then
12291 Exp := Renamed_Object (Ent);
12292 goto Continue;
12293
12294 -- The expression may be the renaming of a subcomponent of an
12295 -- array or container. The assignment to the subcomponent is
12296 -- a modification of the container.
12297
12298 elsif Comes_From_Source (Original_Node (Exp))
12299 and then Nkind_In (Original_Node (Exp), N_Selected_Component,
12300 N_Indexed_Component)
12301 then
12302 Exp := Prefix (Original_Node (Exp));
12303 goto Continue;
12304 end if;
12305
12306 -- Generate a reference only if the assignment comes from
12307 -- source. This excludes, for example, calls to a dispatching
12308 -- assignment operation when the left-hand side is tagged.
12309
12310 if Modification_Comes_From_Source or else SPARK_Mode then
12311 Generate_Reference (Ent, Exp, 'm');
12312
12313 -- If the target of the assignment is the bound variable
12314 -- in an iterator, indicate that the corresponding array
12315 -- or container is also modified.
12316
12317 if Ada_Version >= Ada_2012
12318 and then
12319 Nkind (Parent (Ent)) = N_Iterator_Specification
12320 then
12321 declare
12322 Domain : constant Node_Id := Name (Parent (Ent));
12323
12324 begin
12325 -- TBD : in the full version of the construct, the
12326 -- domain of iteration can be given by an expression.
12327
12328 if Is_Entity_Name (Domain) then
12329 Generate_Reference (Entity (Domain), Exp, 'm');
12330 Set_Is_True_Constant (Entity (Domain), False);
12331 Set_Never_Set_In_Source (Entity (Domain), False);
12332 end if;
12333 end;
12334 end if;
12335 end if;
12336
12337 Check_Nested_Access (Ent);
12338 end if;
12339
12340 Kill_Checks (Ent);
12341
12342 -- If we are sure this is a modification from source, and we know
12343 -- this modifies a constant, then give an appropriate warning.
12344
12345 if Overlays_Constant (Ent)
12346 and then Modification_Comes_From_Source
12347 and then Sure
12348 then
12349 declare
12350 A : constant Node_Id := Address_Clause (Ent);
12351 begin
12352 if Present (A) then
12353 declare
12354 Exp : constant Node_Id := Expression (A);
12355 begin
12356 if Nkind (Exp) = N_Attribute_Reference
12357 and then Attribute_Name (Exp) = Name_Address
12358 and then Is_Entity_Name (Prefix (Exp))
12359 then
12360 Error_Msg_Sloc := Sloc (A);
12361 Error_Msg_NE
12362 ("constant& may be modified via address "
12363 & "clause#??", N, Entity (Prefix (Exp)));
12364 end if;
12365 end;
12366 end if;
12367 end;
12368 end if;
12369
12370 return;
12371 end if;
12372 end loop;
12373 end Note_Possible_Modification;
12374
12375 -------------------------
12376 -- Object_Access_Level --
12377 -------------------------
12378
12379 -- Returns the static accessibility level of the view denoted by Obj. Note
12380 -- that the value returned is the result of a call to Scope_Depth. Only
12381 -- scope depths associated with dynamic scopes can actually be returned.
12382 -- Since only relative levels matter for accessibility checking, the fact
12383 -- that the distance between successive levels of accessibility is not
12384 -- always one is immaterial (invariant: if level(E2) is deeper than
12385 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
12386
12387 function Object_Access_Level (Obj : Node_Id) return Uint is
12388 function Is_Interface_Conversion (N : Node_Id) return Boolean;
12389 -- Determine whether N is a construct of the form
12390 -- Some_Type (Operand._tag'Address)
12391 -- This construct appears in the context of dispatching calls.
12392
12393 function Reference_To (Obj : Node_Id) return Node_Id;
12394 -- An explicit dereference is created when removing side-effects from
12395 -- expressions for constraint checking purposes. In this case a local
12396 -- access type is created for it. The correct access level is that of
12397 -- the original source node. We detect this case by noting that the
12398 -- prefix of the dereference is created by an object declaration whose
12399 -- initial expression is a reference.
12400
12401 -----------------------------
12402 -- Is_Interface_Conversion --
12403 -----------------------------
12404
12405 function Is_Interface_Conversion (N : Node_Id) return Boolean is
12406 begin
12407 return
12408 Nkind (N) = N_Unchecked_Type_Conversion
12409 and then Nkind (Expression (N)) = N_Attribute_Reference
12410 and then Attribute_Name (Expression (N)) = Name_Address;
12411 end Is_Interface_Conversion;
12412
12413 ------------------
12414 -- Reference_To --
12415 ------------------
12416
12417 function Reference_To (Obj : Node_Id) return Node_Id is
12418 Pref : constant Node_Id := Prefix (Obj);
12419 begin
12420 if Is_Entity_Name (Pref)
12421 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
12422 and then Present (Expression (Parent (Entity (Pref))))
12423 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
12424 then
12425 return (Prefix (Expression (Parent (Entity (Pref)))));
12426 else
12427 return Empty;
12428 end if;
12429 end Reference_To;
12430
12431 -- Local variables
12432
12433 E : Entity_Id;
12434
12435 -- Start of processing for Object_Access_Level
12436
12437 begin
12438 if Nkind (Obj) = N_Defining_Identifier
12439 or else Is_Entity_Name (Obj)
12440 then
12441 if Nkind (Obj) = N_Defining_Identifier then
12442 E := Obj;
12443 else
12444 E := Entity (Obj);
12445 end if;
12446
12447 if Is_Prival (E) then
12448 E := Prival_Link (E);
12449 end if;
12450
12451 -- If E is a type then it denotes a current instance. For this case
12452 -- we add one to the normal accessibility level of the type to ensure
12453 -- that current instances are treated as always being deeper than
12454 -- than the level of any visible named access type (see 3.10.2(21)).
12455
12456 if Is_Type (E) then
12457 return Type_Access_Level (E) + 1;
12458
12459 elsif Present (Renamed_Object (E)) then
12460 return Object_Access_Level (Renamed_Object (E));
12461
12462 -- Similarly, if E is a component of the current instance of a
12463 -- protected type, any instance of it is assumed to be at a deeper
12464 -- level than the type. For a protected object (whose type is an
12465 -- anonymous protected type) its components are at the same level
12466 -- as the type itself.
12467
12468 elsif not Is_Overloadable (E)
12469 and then Ekind (Scope (E)) = E_Protected_Type
12470 and then Comes_From_Source (Scope (E))
12471 then
12472 return Type_Access_Level (Scope (E)) + 1;
12473
12474 else
12475 return Scope_Depth (Enclosing_Dynamic_Scope (E));
12476 end if;
12477
12478 elsif Nkind (Obj) = N_Selected_Component then
12479 if Is_Access_Type (Etype (Prefix (Obj))) then
12480 return Type_Access_Level (Etype (Prefix (Obj)));
12481 else
12482 return Object_Access_Level (Prefix (Obj));
12483 end if;
12484
12485 elsif Nkind (Obj) = N_Indexed_Component then
12486 if Is_Access_Type (Etype (Prefix (Obj))) then
12487 return Type_Access_Level (Etype (Prefix (Obj)));
12488 else
12489 return Object_Access_Level (Prefix (Obj));
12490 end if;
12491
12492 elsif Nkind (Obj) = N_Explicit_Dereference then
12493
12494 -- If the prefix is a selected access discriminant then we make a
12495 -- recursive call on the prefix, which will in turn check the level
12496 -- of the prefix object of the selected discriminant.
12497
12498 if Nkind (Prefix (Obj)) = N_Selected_Component
12499 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
12500 and then
12501 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
12502 then
12503 return Object_Access_Level (Prefix (Obj));
12504
12505 -- Detect an interface conversion in the context of a dispatching
12506 -- call. Use the original form of the conversion to find the access
12507 -- level of the operand.
12508
12509 elsif Is_Interface (Etype (Obj))
12510 and then Is_Interface_Conversion (Prefix (Obj))
12511 and then Nkind (Original_Node (Obj)) = N_Type_Conversion
12512 then
12513 return Object_Access_Level (Original_Node (Obj));
12514
12515 elsif not Comes_From_Source (Obj) then
12516 declare
12517 Ref : constant Node_Id := Reference_To (Obj);
12518 begin
12519 if Present (Ref) then
12520 return Object_Access_Level (Ref);
12521 else
12522 return Type_Access_Level (Etype (Prefix (Obj)));
12523 end if;
12524 end;
12525
12526 else
12527 return Type_Access_Level (Etype (Prefix (Obj)));
12528 end if;
12529
12530 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
12531 return Object_Access_Level (Expression (Obj));
12532
12533 elsif Nkind (Obj) = N_Function_Call then
12534
12535 -- Function results are objects, so we get either the access level of
12536 -- the function or, in the case of an indirect call, the level of the
12537 -- access-to-subprogram type. (This code is used for Ada 95, but it
12538 -- looks wrong, because it seems that we should be checking the level
12539 -- of the call itself, even for Ada 95. However, using the Ada 2005
12540 -- version of the code causes regressions in several tests that are
12541 -- compiled with -gnat95. ???)
12542
12543 if Ada_Version < Ada_2005 then
12544 if Is_Entity_Name (Name (Obj)) then
12545 return Subprogram_Access_Level (Entity (Name (Obj)));
12546 else
12547 return Type_Access_Level (Etype (Prefix (Name (Obj))));
12548 end if;
12549
12550 -- For Ada 2005, the level of the result object of a function call is
12551 -- defined to be the level of the call's innermost enclosing master.
12552 -- We determine that by querying the depth of the innermost enclosing
12553 -- dynamic scope.
12554
12555 else
12556 Return_Master_Scope_Depth_Of_Call : declare
12557
12558 function Innermost_Master_Scope_Depth
12559 (N : Node_Id) return Uint;
12560 -- Returns the scope depth of the given node's innermost
12561 -- enclosing dynamic scope (effectively the accessibility
12562 -- level of the innermost enclosing master).
12563
12564 ----------------------------------
12565 -- Innermost_Master_Scope_Depth --
12566 ----------------------------------
12567
12568 function Innermost_Master_Scope_Depth
12569 (N : Node_Id) return Uint
12570 is
12571 Node_Par : Node_Id := Parent (N);
12572
12573 begin
12574 -- Locate the nearest enclosing node (by traversing Parents)
12575 -- that Defining_Entity can be applied to, and return the
12576 -- depth of that entity's nearest enclosing dynamic scope.
12577
12578 while Present (Node_Par) loop
12579 case Nkind (Node_Par) is
12580 when N_Component_Declaration |
12581 N_Entry_Declaration |
12582 N_Formal_Object_Declaration |
12583 N_Formal_Type_Declaration |
12584 N_Full_Type_Declaration |
12585 N_Incomplete_Type_Declaration |
12586 N_Loop_Parameter_Specification |
12587 N_Object_Declaration |
12588 N_Protected_Type_Declaration |
12589 N_Private_Extension_Declaration |
12590 N_Private_Type_Declaration |
12591 N_Subtype_Declaration |
12592 N_Function_Specification |
12593 N_Procedure_Specification |
12594 N_Task_Type_Declaration |
12595 N_Body_Stub |
12596 N_Generic_Instantiation |
12597 N_Proper_Body |
12598 N_Implicit_Label_Declaration |
12599 N_Package_Declaration |
12600 N_Single_Task_Declaration |
12601 N_Subprogram_Declaration |
12602 N_Generic_Declaration |
12603 N_Renaming_Declaration |
12604 N_Block_Statement |
12605 N_Formal_Subprogram_Declaration |
12606 N_Abstract_Subprogram_Declaration |
12607 N_Entry_Body |
12608 N_Exception_Declaration |
12609 N_Formal_Package_Declaration |
12610 N_Number_Declaration |
12611 N_Package_Specification |
12612 N_Parameter_Specification |
12613 N_Single_Protected_Declaration |
12614 N_Subunit =>
12615
12616 return Scope_Depth
12617 (Nearest_Dynamic_Scope
12618 (Defining_Entity (Node_Par)));
12619
12620 when others =>
12621 null;
12622 end case;
12623
12624 Node_Par := Parent (Node_Par);
12625 end loop;
12626
12627 pragma Assert (False);
12628
12629 -- Should never reach the following return
12630
12631 return Scope_Depth (Current_Scope) + 1;
12632 end Innermost_Master_Scope_Depth;
12633
12634 -- Start of processing for Return_Master_Scope_Depth_Of_Call
12635
12636 begin
12637 return Innermost_Master_Scope_Depth (Obj);
12638 end Return_Master_Scope_Depth_Of_Call;
12639 end if;
12640
12641 -- For convenience we handle qualified expressions, even though they
12642 -- aren't technically object names.
12643
12644 elsif Nkind (Obj) = N_Qualified_Expression then
12645 return Object_Access_Level (Expression (Obj));
12646
12647 -- Otherwise return the scope level of Standard. (If there are cases
12648 -- that fall through to this point they will be treated as having
12649 -- global accessibility for now. ???)
12650
12651 else
12652 return Scope_Depth (Standard_Standard);
12653 end if;
12654 end Object_Access_Level;
12655
12656 --------------------------------------
12657 -- Original_Corresponding_Operation --
12658 --------------------------------------
12659
12660 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
12661 is
12662 Typ : constant Entity_Id := Find_Dispatching_Type (S);
12663
12664 begin
12665 -- If S is an inherited primitive S2 the original corresponding
12666 -- operation of S is the original corresponding operation of S2
12667
12668 if Present (Alias (S))
12669 and then Find_Dispatching_Type (Alias (S)) /= Typ
12670 then
12671 return Original_Corresponding_Operation (Alias (S));
12672
12673 -- If S overrides an inherited subprogram S2 the original corresponding
12674 -- operation of S is the original corresponding operation of S2
12675
12676 elsif Present (Overridden_Operation (S)) then
12677 return Original_Corresponding_Operation (Overridden_Operation (S));
12678
12679 -- otherwise it is S itself
12680
12681 else
12682 return S;
12683 end if;
12684 end Original_Corresponding_Operation;
12685
12686 -----------------------
12687 -- Private_Component --
12688 -----------------------
12689
12690 function Private_Component (Type_Id : Entity_Id) return Entity_Id is
12691 Ancestor : constant Entity_Id := Base_Type (Type_Id);
12692
12693 function Trace_Components
12694 (T : Entity_Id;
12695 Check : Boolean) return Entity_Id;
12696 -- Recursive function that does the work, and checks against circular
12697 -- definition for each subcomponent type.
12698
12699 ----------------------
12700 -- Trace_Components --
12701 ----------------------
12702
12703 function Trace_Components
12704 (T : Entity_Id;
12705 Check : Boolean) return Entity_Id
12706 is
12707 Btype : constant Entity_Id := Base_Type (T);
12708 Component : Entity_Id;
12709 P : Entity_Id;
12710 Candidate : Entity_Id := Empty;
12711
12712 begin
12713 if Check and then Btype = Ancestor then
12714 Error_Msg_N ("circular type definition", Type_Id);
12715 return Any_Type;
12716 end if;
12717
12718 if Is_Private_Type (Btype)
12719 and then not Is_Generic_Type (Btype)
12720 then
12721 if Present (Full_View (Btype))
12722 and then Is_Record_Type (Full_View (Btype))
12723 and then not Is_Frozen (Btype)
12724 then
12725 -- To indicate that the ancestor depends on a private type, the
12726 -- current Btype is sufficient. However, to check for circular
12727 -- definition we must recurse on the full view.
12728
12729 Candidate := Trace_Components (Full_View (Btype), True);
12730
12731 if Candidate = Any_Type then
12732 return Any_Type;
12733 else
12734 return Btype;
12735 end if;
12736
12737 else
12738 return Btype;
12739 end if;
12740
12741 elsif Is_Array_Type (Btype) then
12742 return Trace_Components (Component_Type (Btype), True);
12743
12744 elsif Is_Record_Type (Btype) then
12745 Component := First_Entity (Btype);
12746 while Present (Component)
12747 and then Comes_From_Source (Component)
12748 loop
12749 -- Skip anonymous types generated by constrained components
12750
12751 if not Is_Type (Component) then
12752 P := Trace_Components (Etype (Component), True);
12753
12754 if Present (P) then
12755 if P = Any_Type then
12756 return P;
12757 else
12758 Candidate := P;
12759 end if;
12760 end if;
12761 end if;
12762
12763 Next_Entity (Component);
12764 end loop;
12765
12766 return Candidate;
12767
12768 else
12769 return Empty;
12770 end if;
12771 end Trace_Components;
12772
12773 -- Start of processing for Private_Component
12774
12775 begin
12776 return Trace_Components (Type_Id, False);
12777 end Private_Component;
12778
12779 ---------------------------
12780 -- Primitive_Names_Match --
12781 ---------------------------
12782
12783 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
12784
12785 function Non_Internal_Name (E : Entity_Id) return Name_Id;
12786 -- Given an internal name, returns the corresponding non-internal name
12787
12788 ------------------------
12789 -- Non_Internal_Name --
12790 ------------------------
12791
12792 function Non_Internal_Name (E : Entity_Id) return Name_Id is
12793 begin
12794 Get_Name_String (Chars (E));
12795 Name_Len := Name_Len - 1;
12796 return Name_Find;
12797 end Non_Internal_Name;
12798
12799 -- Start of processing for Primitive_Names_Match
12800
12801 begin
12802 pragma Assert (Present (E1) and then Present (E2));
12803
12804 return Chars (E1) = Chars (E2)
12805 or else
12806 (not Is_Internal_Name (Chars (E1))
12807 and then Is_Internal_Name (Chars (E2))
12808 and then Non_Internal_Name (E2) = Chars (E1))
12809 or else
12810 (not Is_Internal_Name (Chars (E2))
12811 and then Is_Internal_Name (Chars (E1))
12812 and then Non_Internal_Name (E1) = Chars (E2))
12813 or else
12814 (Is_Predefined_Dispatching_Operation (E1)
12815 and then Is_Predefined_Dispatching_Operation (E2)
12816 and then Same_TSS (E1, E2))
12817 or else
12818 (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
12819 end Primitive_Names_Match;
12820
12821 -----------------------
12822 -- Process_End_Label --
12823 -----------------------
12824
12825 procedure Process_End_Label
12826 (N : Node_Id;
12827 Typ : Character;
12828 Ent : Entity_Id)
12829 is
12830 Loc : Source_Ptr;
12831 Nam : Node_Id;
12832 Scop : Entity_Id;
12833
12834 Label_Ref : Boolean;
12835 -- Set True if reference to end label itself is required
12836
12837 Endl : Node_Id;
12838 -- Gets set to the operator symbol or identifier that references the
12839 -- entity Ent. For the child unit case, this is the identifier from the
12840 -- designator. For other cases, this is simply Endl.
12841
12842 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
12843 -- N is an identifier node that appears as a parent unit reference in
12844 -- the case where Ent is a child unit. This procedure generates an
12845 -- appropriate cross-reference entry. E is the corresponding entity.
12846
12847 -------------------------
12848 -- Generate_Parent_Ref --
12849 -------------------------
12850
12851 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
12852 begin
12853 -- If names do not match, something weird, skip reference
12854
12855 if Chars (E) = Chars (N) then
12856
12857 -- Generate the reference. We do NOT consider this as a reference
12858 -- for unreferenced symbol purposes.
12859
12860 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
12861
12862 if Style_Check then
12863 Style.Check_Identifier (N, E);
12864 end if;
12865 end if;
12866 end Generate_Parent_Ref;
12867
12868 -- Start of processing for Process_End_Label
12869
12870 begin
12871 -- If no node, ignore. This happens in some error situations, and
12872 -- also for some internally generated structures where no end label
12873 -- references are required in any case.
12874
12875 if No (N) then
12876 return;
12877 end if;
12878
12879 -- Nothing to do if no End_Label, happens for internally generated
12880 -- constructs where we don't want an end label reference anyway. Also
12881 -- nothing to do if Endl is a string literal, which means there was
12882 -- some prior error (bad operator symbol)
12883
12884 Endl := End_Label (N);
12885
12886 if No (Endl) or else Nkind (Endl) = N_String_Literal then
12887 return;
12888 end if;
12889
12890 -- Reference node is not in extended main source unit
12891
12892 if not In_Extended_Main_Source_Unit (N) then
12893
12894 -- Generally we do not collect references except for the extended
12895 -- main source unit. The one exception is the 'e' entry for a
12896 -- package spec, where it is useful for a client to have the
12897 -- ending information to define scopes.
12898
12899 if Typ /= 'e' then
12900 return;
12901
12902 else
12903 Label_Ref := False;
12904
12905 -- For this case, we can ignore any parent references, but we
12906 -- need the package name itself for the 'e' entry.
12907
12908 if Nkind (Endl) = N_Designator then
12909 Endl := Identifier (Endl);
12910 end if;
12911 end if;
12912
12913 -- Reference is in extended main source unit
12914
12915 else
12916 Label_Ref := True;
12917
12918 -- For designator, generate references for the parent entries
12919
12920 if Nkind (Endl) = N_Designator then
12921
12922 -- Generate references for the prefix if the END line comes from
12923 -- source (otherwise we do not need these references) We climb the
12924 -- scope stack to find the expected entities.
12925
12926 if Comes_From_Source (Endl) then
12927 Nam := Name (Endl);
12928 Scop := Current_Scope;
12929 while Nkind (Nam) = N_Selected_Component loop
12930 Scop := Scope (Scop);
12931 exit when No (Scop);
12932 Generate_Parent_Ref (Selector_Name (Nam), Scop);
12933 Nam := Prefix (Nam);
12934 end loop;
12935
12936 if Present (Scop) then
12937 Generate_Parent_Ref (Nam, Scope (Scop));
12938 end if;
12939 end if;
12940
12941 Endl := Identifier (Endl);
12942 end if;
12943 end if;
12944
12945 -- If the end label is not for the given entity, then either we have
12946 -- some previous error, or this is a generic instantiation for which
12947 -- we do not need to make a cross-reference in this case anyway. In
12948 -- either case we simply ignore the call.
12949
12950 if Chars (Ent) /= Chars (Endl) then
12951 return;
12952 end if;
12953
12954 -- If label was really there, then generate a normal reference and then
12955 -- adjust the location in the end label to point past the name (which
12956 -- should almost always be the semicolon).
12957
12958 Loc := Sloc (Endl);
12959
12960 if Comes_From_Source (Endl) then
12961
12962 -- If a label reference is required, then do the style check and
12963 -- generate an l-type cross-reference entry for the label
12964
12965 if Label_Ref then
12966 if Style_Check then
12967 Style.Check_Identifier (Endl, Ent);
12968 end if;
12969
12970 Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
12971 end if;
12972
12973 -- Set the location to point past the label (normally this will
12974 -- mean the semicolon immediately following the label). This is
12975 -- done for the sake of the 'e' or 't' entry generated below.
12976
12977 Get_Decoded_Name_String (Chars (Endl));
12978 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
12979
12980 else
12981 -- In SPARK mode, no missing label is allowed for packages and
12982 -- subprogram bodies. Detect those cases by testing whether
12983 -- Process_End_Label was called for a body (Typ = 't') or a package.
12984
12985 if Restriction_Check_Required (SPARK_05)
12986 and then (Typ = 't' or else Ekind (Ent) = E_Package)
12987 then
12988 Error_Msg_Node_1 := Endl;
12989 Check_SPARK_Restriction ("`END &` required", Endl, Force => True);
12990 end if;
12991 end if;
12992
12993 -- Now generate the e/t reference
12994
12995 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
12996
12997 -- Restore Sloc, in case modified above, since we have an identifier
12998 -- and the normal Sloc should be left set in the tree.
12999
13000 Set_Sloc (Endl, Loc);
13001 end Process_End_Label;
13002
13003 ----------------
13004 -- Referenced --
13005 ----------------
13006
13007 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is
13008 Seen : Boolean := False;
13009
13010 function Is_Reference (N : Node_Id) return Traverse_Result;
13011 -- Determine whether node N denotes a reference to Id. If this is the
13012 -- case, set global flag Seen to True and stop the traversal.
13013
13014 ------------------
13015 -- Is_Reference --
13016 ------------------
13017
13018 function Is_Reference (N : Node_Id) return Traverse_Result is
13019 begin
13020 if Is_Entity_Name (N)
13021 and then Present (Entity (N))
13022 and then Entity (N) = Id
13023 then
13024 Seen := True;
13025 return Abandon;
13026 else
13027 return OK;
13028 end if;
13029 end Is_Reference;
13030
13031 procedure Inspect_Expression is new Traverse_Proc (Is_Reference);
13032
13033 -- Start of processing for Referenced
13034
13035 begin
13036 Inspect_Expression (Expr);
13037 return Seen;
13038 end Referenced;
13039
13040 ------------------------------------
13041 -- References_Generic_Formal_Type --
13042 ------------------------------------
13043
13044 function References_Generic_Formal_Type (N : Node_Id) return Boolean is
13045
13046 function Process (N : Node_Id) return Traverse_Result;
13047 -- Process one node in search for generic formal type
13048
13049 -------------
13050 -- Process --
13051 -------------
13052
13053 function Process (N : Node_Id) return Traverse_Result is
13054 begin
13055 if Nkind (N) in N_Has_Entity then
13056 declare
13057 E : constant Entity_Id := Entity (N);
13058 begin
13059 if Present (E) then
13060 if Is_Generic_Type (E) then
13061 return Abandon;
13062 elsif Present (Etype (E))
13063 and then Is_Generic_Type (Etype (E))
13064 then
13065 return Abandon;
13066 end if;
13067 end if;
13068 end;
13069 end if;
13070
13071 return Atree.OK;
13072 end Process;
13073
13074 function Traverse is new Traverse_Func (Process);
13075 -- Traverse tree to look for generic type
13076
13077 begin
13078 if Inside_A_Generic then
13079 return Traverse (N) = Abandon;
13080 else
13081 return False;
13082 end if;
13083 end References_Generic_Formal_Type;
13084
13085 --------------------
13086 -- Remove_Homonym --
13087 --------------------
13088
13089 procedure Remove_Homonym (E : Entity_Id) is
13090 Prev : Entity_Id := Empty;
13091 H : Entity_Id;
13092
13093 begin
13094 if E = Current_Entity (E) then
13095 if Present (Homonym (E)) then
13096 Set_Current_Entity (Homonym (E));
13097 else
13098 Set_Name_Entity_Id (Chars (E), Empty);
13099 end if;
13100
13101 else
13102 H := Current_Entity (E);
13103 while Present (H) and then H /= E loop
13104 Prev := H;
13105 H := Homonym (H);
13106 end loop;
13107
13108 -- If E is not on the homonym chain, nothing to do
13109
13110 if Present (H) then
13111 Set_Homonym (Prev, Homonym (E));
13112 end if;
13113 end if;
13114 end Remove_Homonym;
13115
13116 ---------------------
13117 -- Rep_To_Pos_Flag --
13118 ---------------------
13119
13120 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
13121 begin
13122 return New_Occurrence_Of
13123 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
13124 end Rep_To_Pos_Flag;
13125
13126 --------------------
13127 -- Require_Entity --
13128 --------------------
13129
13130 procedure Require_Entity (N : Node_Id) is
13131 begin
13132 if Is_Entity_Name (N) and then No (Entity (N)) then
13133 if Total_Errors_Detected /= 0 then
13134 Set_Entity (N, Any_Id);
13135 else
13136 raise Program_Error;
13137 end if;
13138 end if;
13139 end Require_Entity;
13140
13141 ------------------------------
13142 -- Requires_Transient_Scope --
13143 ------------------------------
13144
13145 -- A transient scope is required when variable-sized temporaries are
13146 -- allocated in the primary or secondary stack, or when finalization
13147 -- actions must be generated before the next instruction.
13148
13149 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
13150 Typ : constant Entity_Id := Underlying_Type (Id);
13151
13152 -- Start of processing for Requires_Transient_Scope
13153
13154 begin
13155 -- This is a private type which is not completed yet. This can only
13156 -- happen in a default expression (of a formal parameter or of a
13157 -- record component). Do not expand transient scope in this case
13158
13159 if No (Typ) then
13160 return False;
13161
13162 -- Do not expand transient scope for non-existent procedure return
13163
13164 elsif Typ = Standard_Void_Type then
13165 return False;
13166
13167 -- Elementary types do not require a transient scope
13168
13169 elsif Is_Elementary_Type (Typ) then
13170 return False;
13171
13172 -- Generally, indefinite subtypes require a transient scope, since the
13173 -- back end cannot generate temporaries, since this is not a valid type
13174 -- for declaring an object. It might be possible to relax this in the
13175 -- future, e.g. by declaring the maximum possible space for the type.
13176
13177 elsif Is_Indefinite_Subtype (Typ) then
13178 return True;
13179
13180 -- Functions returning tagged types may dispatch on result so their
13181 -- returned value is allocated on the secondary stack. Controlled
13182 -- type temporaries need finalization.
13183
13184 elsif Is_Tagged_Type (Typ)
13185 or else Has_Controlled_Component (Typ)
13186 then
13187 return not Is_Value_Type (Typ);
13188
13189 -- Record type
13190
13191 elsif Is_Record_Type (Typ) then
13192 declare
13193 Comp : Entity_Id;
13194 begin
13195 Comp := First_Entity (Typ);
13196 while Present (Comp) loop
13197 if Ekind (Comp) = E_Component
13198 and then Requires_Transient_Scope (Etype (Comp))
13199 then
13200 return True;
13201 else
13202 Next_Entity (Comp);
13203 end if;
13204 end loop;
13205 end;
13206
13207 return False;
13208
13209 -- String literal types never require transient scope
13210
13211 elsif Ekind (Typ) = E_String_Literal_Subtype then
13212 return False;
13213
13214 -- Array type. Note that we already know that this is a constrained
13215 -- array, since unconstrained arrays will fail the indefinite test.
13216
13217 elsif Is_Array_Type (Typ) then
13218
13219 -- If component type requires a transient scope, the array does too
13220
13221 if Requires_Transient_Scope (Component_Type (Typ)) then
13222 return True;
13223
13224 -- Otherwise, we only need a transient scope if the size depends on
13225 -- the value of one or more discriminants.
13226
13227 else
13228 return Size_Depends_On_Discriminant (Typ);
13229 end if;
13230
13231 -- All other cases do not require a transient scope
13232
13233 else
13234 return False;
13235 end if;
13236 end Requires_Transient_Scope;
13237
13238 --------------------------
13239 -- Reset_Analyzed_Flags --
13240 --------------------------
13241
13242 procedure Reset_Analyzed_Flags (N : Node_Id) is
13243
13244 function Clear_Analyzed (N : Node_Id) return Traverse_Result;
13245 -- Function used to reset Analyzed flags in tree. Note that we do
13246 -- not reset Analyzed flags in entities, since there is no need to
13247 -- reanalyze entities, and indeed, it is wrong to do so, since it
13248 -- can result in generating auxiliary stuff more than once.
13249
13250 --------------------
13251 -- Clear_Analyzed --
13252 --------------------
13253
13254 function Clear_Analyzed (N : Node_Id) return Traverse_Result is
13255 begin
13256 if not Has_Extension (N) then
13257 Set_Analyzed (N, False);
13258 end if;
13259
13260 return OK;
13261 end Clear_Analyzed;
13262
13263 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
13264
13265 -- Start of processing for Reset_Analyzed_Flags
13266
13267 begin
13268 Reset_Analyzed (N);
13269 end Reset_Analyzed_Flags;
13270
13271 --------------------------------
13272 -- Returns_Unconstrained_Type --
13273 --------------------------------
13274
13275 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
13276 begin
13277 return Ekind (Subp) = E_Function
13278 and then not Is_Scalar_Type (Etype (Subp))
13279 and then not Is_Access_Type (Etype (Subp))
13280 and then not Is_Constrained (Etype (Subp));
13281 end Returns_Unconstrained_Type;
13282
13283 ---------------------------
13284 -- Safe_To_Capture_Value --
13285 ---------------------------
13286
13287 function Safe_To_Capture_Value
13288 (N : Node_Id;
13289 Ent : Entity_Id;
13290 Cond : Boolean := False) return Boolean
13291 is
13292 begin
13293 -- The only entities for which we track constant values are variables
13294 -- which are not renamings, constants, out parameters, and in out
13295 -- parameters, so check if we have this case.
13296
13297 -- Note: it may seem odd to track constant values for constants, but in
13298 -- fact this routine is used for other purposes than simply capturing
13299 -- the value. In particular, the setting of Known[_Non]_Null.
13300
13301 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
13302 or else
13303 Ekind (Ent) = E_Constant
13304 or else
13305 Ekind (Ent) = E_Out_Parameter
13306 or else
13307 Ekind (Ent) = E_In_Out_Parameter
13308 then
13309 null;
13310
13311 -- For conditionals, we also allow loop parameters and all formals,
13312 -- including in parameters.
13313
13314 elsif Cond
13315 and then
13316 (Ekind (Ent) = E_Loop_Parameter
13317 or else
13318 Ekind (Ent) = E_In_Parameter)
13319 then
13320 null;
13321
13322 -- For all other cases, not just unsafe, but impossible to capture
13323 -- Current_Value, since the above are the only entities which have
13324 -- Current_Value fields.
13325
13326 else
13327 return False;
13328 end if;
13329
13330 -- Skip if volatile or aliased, since funny things might be going on in
13331 -- these cases which we cannot necessarily track. Also skip any variable
13332 -- for which an address clause is given, or whose address is taken. Also
13333 -- never capture value of library level variables (an attempt to do so
13334 -- can occur in the case of package elaboration code).
13335
13336 if Treat_As_Volatile (Ent)
13337 or else Is_Aliased (Ent)
13338 or else Present (Address_Clause (Ent))
13339 or else Address_Taken (Ent)
13340 or else (Is_Library_Level_Entity (Ent)
13341 and then Ekind (Ent) = E_Variable)
13342 then
13343 return False;
13344 end if;
13345
13346 -- OK, all above conditions are met. We also require that the scope of
13347 -- the reference be the same as the scope of the entity, not counting
13348 -- packages and blocks and loops.
13349
13350 declare
13351 E_Scope : constant Entity_Id := Scope (Ent);
13352 R_Scope : Entity_Id;
13353
13354 begin
13355 R_Scope := Current_Scope;
13356 while R_Scope /= Standard_Standard loop
13357 exit when R_Scope = E_Scope;
13358
13359 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
13360 return False;
13361 else
13362 R_Scope := Scope (R_Scope);
13363 end if;
13364 end loop;
13365 end;
13366
13367 -- We also require that the reference does not appear in a context
13368 -- where it is not sure to be executed (i.e. a conditional context
13369 -- or an exception handler). We skip this if Cond is True, since the
13370 -- capturing of values from conditional tests handles this ok.
13371
13372 if Cond then
13373 return True;
13374 end if;
13375
13376 declare
13377 Desc : Node_Id;
13378 P : Node_Id;
13379
13380 begin
13381 Desc := N;
13382
13383 -- Seems dubious that case expressions are not handled here ???
13384
13385 P := Parent (N);
13386 while Present (P) loop
13387 if Nkind (P) = N_If_Statement
13388 or else Nkind (P) = N_Case_Statement
13389 or else (Nkind (P) in N_Short_Circuit
13390 and then Desc = Right_Opnd (P))
13391 or else (Nkind (P) = N_If_Expression
13392 and then Desc /= First (Expressions (P)))
13393 or else Nkind (P) = N_Exception_Handler
13394 or else Nkind (P) = N_Selective_Accept
13395 or else Nkind (P) = N_Conditional_Entry_Call
13396 or else Nkind (P) = N_Timed_Entry_Call
13397 or else Nkind (P) = N_Asynchronous_Select
13398 then
13399 return False;
13400 else
13401 Desc := P;
13402 P := Parent (P);
13403
13404 -- A special Ada 2012 case: the original node may be part
13405 -- of the else_actions of a conditional expression, in which
13406 -- case it might not have been expanded yet, and appears in
13407 -- a non-syntactic list of actions. In that case it is clearly
13408 -- not safe to save a value.
13409
13410 if No (P)
13411 and then Is_List_Member (Desc)
13412 and then No (Parent (List_Containing (Desc)))
13413 then
13414 return False;
13415 end if;
13416 end if;
13417 end loop;
13418 end;
13419
13420 -- OK, looks safe to set value
13421
13422 return True;
13423 end Safe_To_Capture_Value;
13424
13425 ---------------
13426 -- Same_Name --
13427 ---------------
13428
13429 function Same_Name (N1, N2 : Node_Id) return Boolean is
13430 K1 : constant Node_Kind := Nkind (N1);
13431 K2 : constant Node_Kind := Nkind (N2);
13432
13433 begin
13434 if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
13435 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
13436 then
13437 return Chars (N1) = Chars (N2);
13438
13439 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
13440 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
13441 then
13442 return Same_Name (Selector_Name (N1), Selector_Name (N2))
13443 and then Same_Name (Prefix (N1), Prefix (N2));
13444
13445 else
13446 return False;
13447 end if;
13448 end Same_Name;
13449
13450 -----------------
13451 -- Same_Object --
13452 -----------------
13453
13454 function Same_Object (Node1, Node2 : Node_Id) return Boolean is
13455 N1 : constant Node_Id := Original_Node (Node1);
13456 N2 : constant Node_Id := Original_Node (Node2);
13457 -- We do the tests on original nodes, since we are most interested
13458 -- in the original source, not any expansion that got in the way.
13459
13460 K1 : constant Node_Kind := Nkind (N1);
13461 K2 : constant Node_Kind := Nkind (N2);
13462
13463 begin
13464 -- First case, both are entities with same entity
13465
13466 if K1 in N_Has_Entity and then K2 in N_Has_Entity then
13467 declare
13468 EN1 : constant Entity_Id := Entity (N1);
13469 EN2 : constant Entity_Id := Entity (N2);
13470 begin
13471 if Present (EN1) and then Present (EN2)
13472 and then (Ekind_In (EN1, E_Variable, E_Constant)
13473 or else Is_Formal (EN1))
13474 and then EN1 = EN2
13475 then
13476 return True;
13477 end if;
13478 end;
13479 end if;
13480
13481 -- Second case, selected component with same selector, same record
13482
13483 if K1 = N_Selected_Component
13484 and then K2 = N_Selected_Component
13485 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
13486 then
13487 return Same_Object (Prefix (N1), Prefix (N2));
13488
13489 -- Third case, indexed component with same subscripts, same array
13490
13491 elsif K1 = N_Indexed_Component
13492 and then K2 = N_Indexed_Component
13493 and then Same_Object (Prefix (N1), Prefix (N2))
13494 then
13495 declare
13496 E1, E2 : Node_Id;
13497 begin
13498 E1 := First (Expressions (N1));
13499 E2 := First (Expressions (N2));
13500 while Present (E1) loop
13501 if not Same_Value (E1, E2) then
13502 return False;
13503 else
13504 Next (E1);
13505 Next (E2);
13506 end if;
13507 end loop;
13508
13509 return True;
13510 end;
13511
13512 -- Fourth case, slice of same array with same bounds
13513
13514 elsif K1 = N_Slice
13515 and then K2 = N_Slice
13516 and then Nkind (Discrete_Range (N1)) = N_Range
13517 and then Nkind (Discrete_Range (N2)) = N_Range
13518 and then Same_Value (Low_Bound (Discrete_Range (N1)),
13519 Low_Bound (Discrete_Range (N2)))
13520 and then Same_Value (High_Bound (Discrete_Range (N1)),
13521 High_Bound (Discrete_Range (N2)))
13522 then
13523 return Same_Name (Prefix (N1), Prefix (N2));
13524
13525 -- All other cases, not clearly the same object
13526
13527 else
13528 return False;
13529 end if;
13530 end Same_Object;
13531
13532 ---------------
13533 -- Same_Type --
13534 ---------------
13535
13536 function Same_Type (T1, T2 : Entity_Id) return Boolean is
13537 begin
13538 if T1 = T2 then
13539 return True;
13540
13541 elsif not Is_Constrained (T1)
13542 and then not Is_Constrained (T2)
13543 and then Base_Type (T1) = Base_Type (T2)
13544 then
13545 return True;
13546
13547 -- For now don't bother with case of identical constraints, to be
13548 -- fiddled with later on perhaps (this is only used for optimization
13549 -- purposes, so it is not critical to do a best possible job)
13550
13551 else
13552 return False;
13553 end if;
13554 end Same_Type;
13555
13556 ----------------
13557 -- Same_Value --
13558 ----------------
13559
13560 function Same_Value (Node1, Node2 : Node_Id) return Boolean is
13561 begin
13562 if Compile_Time_Known_Value (Node1)
13563 and then Compile_Time_Known_Value (Node2)
13564 and then Expr_Value (Node1) = Expr_Value (Node2)
13565 then
13566 return True;
13567 elsif Same_Object (Node1, Node2) then
13568 return True;
13569 else
13570 return False;
13571 end if;
13572 end Same_Value;
13573
13574 ------------------------
13575 -- Scope_Is_Transient --
13576 ------------------------
13577
13578 function Scope_Is_Transient return Boolean is
13579 begin
13580 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
13581 end Scope_Is_Transient;
13582
13583 ------------------
13584 -- Scope_Within --
13585 ------------------
13586
13587 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
13588 Scop : Entity_Id;
13589
13590 begin
13591 Scop := Scope1;
13592 while Scop /= Standard_Standard loop
13593 Scop := Scope (Scop);
13594
13595 if Scop = Scope2 then
13596 return True;
13597 end if;
13598 end loop;
13599
13600 return False;
13601 end Scope_Within;
13602
13603 --------------------------
13604 -- Scope_Within_Or_Same --
13605 --------------------------
13606
13607 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
13608 Scop : Entity_Id;
13609
13610 begin
13611 Scop := Scope1;
13612 while Scop /= Standard_Standard loop
13613 if Scop = Scope2 then
13614 return True;
13615 else
13616 Scop := Scope (Scop);
13617 end if;
13618 end loop;
13619
13620 return False;
13621 end Scope_Within_Or_Same;
13622
13623 --------------------
13624 -- Set_Convention --
13625 --------------------
13626
13627 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
13628 begin
13629 Basic_Set_Convention (E, Val);
13630
13631 if Is_Type (E)
13632 and then Is_Access_Subprogram_Type (Base_Type (E))
13633 and then Has_Foreign_Convention (E)
13634 then
13635 Set_Can_Use_Internal_Rep (E, False);
13636 end if;
13637 end Set_Convention;
13638
13639 ------------------------
13640 -- Set_Current_Entity --
13641 ------------------------
13642
13643 -- The given entity is to be set as the currently visible definition of its
13644 -- associated name (i.e. the Node_Id associated with its name). All we have
13645 -- to do is to get the name from the identifier, and then set the
13646 -- associated Node_Id to point to the given entity.
13647
13648 procedure Set_Current_Entity (E : Entity_Id) is
13649 begin
13650 Set_Name_Entity_Id (Chars (E), E);
13651 end Set_Current_Entity;
13652
13653 ---------------------------
13654 -- Set_Debug_Info_Needed --
13655 ---------------------------
13656
13657 procedure Set_Debug_Info_Needed (T : Entity_Id) is
13658
13659 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
13660 pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
13661 -- Used to set debug info in a related node if not set already
13662
13663 --------------------------------------
13664 -- Set_Debug_Info_Needed_If_Not_Set --
13665 --------------------------------------
13666
13667 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
13668 begin
13669 if Present (E)
13670 and then not Needs_Debug_Info (E)
13671 then
13672 Set_Debug_Info_Needed (E);
13673
13674 -- For a private type, indicate that the full view also needs
13675 -- debug information.
13676
13677 if Is_Type (E)
13678 and then Is_Private_Type (E)
13679 and then Present (Full_View (E))
13680 then
13681 Set_Debug_Info_Needed (Full_View (E));
13682 end if;
13683 end if;
13684 end Set_Debug_Info_Needed_If_Not_Set;
13685
13686 -- Start of processing for Set_Debug_Info_Needed
13687
13688 begin
13689 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which
13690 -- indicates that Debug_Info_Needed is never required for the entity.
13691
13692 if No (T)
13693 or else Debug_Info_Off (T)
13694 then
13695 return;
13696 end if;
13697
13698 -- Set flag in entity itself. Note that we will go through the following
13699 -- circuitry even if the flag is already set on T. That's intentional,
13700 -- it makes sure that the flag will be set in subsidiary entities.
13701
13702 Set_Needs_Debug_Info (T);
13703
13704 -- Set flag on subsidiary entities if not set already
13705
13706 if Is_Object (T) then
13707 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
13708
13709 elsif Is_Type (T) then
13710 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
13711
13712 if Is_Record_Type (T) then
13713 declare
13714 Ent : Entity_Id := First_Entity (T);
13715 begin
13716 while Present (Ent) loop
13717 Set_Debug_Info_Needed_If_Not_Set (Ent);
13718 Next_Entity (Ent);
13719 end loop;
13720 end;
13721
13722 -- For a class wide subtype, we also need debug information
13723 -- for the equivalent type.
13724
13725 if Ekind (T) = E_Class_Wide_Subtype then
13726 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
13727 end if;
13728
13729 elsif Is_Array_Type (T) then
13730 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
13731
13732 declare
13733 Indx : Node_Id := First_Index (T);
13734 begin
13735 while Present (Indx) loop
13736 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
13737 Indx := Next_Index (Indx);
13738 end loop;
13739 end;
13740
13741 -- For a packed array type, we also need debug information for
13742 -- the type used to represent the packed array. Conversely, we
13743 -- also need it for the former if we need it for the latter.
13744
13745 if Is_Packed (T) then
13746 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
13747 end if;
13748
13749 if Is_Packed_Array_Type (T) then
13750 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T));
13751 end if;
13752
13753 elsif Is_Access_Type (T) then
13754 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
13755
13756 elsif Is_Private_Type (T) then
13757 Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
13758
13759 elsif Is_Protected_Type (T) then
13760 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
13761 end if;
13762 end if;
13763 end Set_Debug_Info_Needed;
13764
13765 ---------------------------------
13766 -- Set_Entity_With_Style_Check --
13767 ---------------------------------
13768
13769 procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
13770 Val_Actual : Entity_Id;
13771 Nod : Node_Id;
13772
13773 begin
13774 -- Unconditionally set the entity
13775
13776 Set_Entity (N, Val);
13777
13778 -- Check for No_Implementation_Identifiers
13779
13780 if Restriction_Check_Required (No_Implementation_Identifiers) then
13781
13782 -- We have an implementation defined entity if it is marked as
13783 -- implementation defined, or is defined in a package marked as
13784 -- implementation defined. However, library packages themselves
13785 -- are excluded (we don't want to flag Interfaces itself, just
13786 -- the entities within it).
13787
13788 if (Is_Implementation_Defined (Val)
13789 or else
13790 Is_Implementation_Defined (Scope (Val)))
13791 and then not (Ekind_In (Val, E_Package, E_Generic_Package)
13792 and then Is_Library_Level_Entity (Val))
13793 then
13794 Check_Restriction (No_Implementation_Identifiers, N);
13795 end if;
13796 end if;
13797
13798 -- Do the style check
13799
13800 if Style_Check
13801 and then not Suppress_Style_Checks (Val)
13802 and then not In_Instance
13803 then
13804 if Nkind (N) = N_Identifier then
13805 Nod := N;
13806 elsif Nkind (N) = N_Expanded_Name then
13807 Nod := Selector_Name (N);
13808 else
13809 return;
13810 end if;
13811
13812 -- A special situation arises for derived operations, where we want
13813 -- to do the check against the parent (since the Sloc of the derived
13814 -- operation points to the derived type declaration itself).
13815
13816 Val_Actual := Val;
13817 while not Comes_From_Source (Val_Actual)
13818 and then Nkind (Val_Actual) in N_Entity
13819 and then (Ekind (Val_Actual) = E_Enumeration_Literal
13820 or else Is_Subprogram (Val_Actual)
13821 or else Is_Generic_Subprogram (Val_Actual))
13822 and then Present (Alias (Val_Actual))
13823 loop
13824 Val_Actual := Alias (Val_Actual);
13825 end loop;
13826
13827 -- Renaming declarations for generic actuals do not come from source,
13828 -- and have a different name from that of the entity they rename, so
13829 -- there is no style check to perform here.
13830
13831 if Chars (Nod) = Chars (Val_Actual) then
13832 Style.Check_Identifier (Nod, Val_Actual);
13833 end if;
13834 end if;
13835
13836 Set_Entity (N, Val);
13837 end Set_Entity_With_Style_Check;
13838
13839 ------------------------
13840 -- Set_Name_Entity_Id --
13841 ------------------------
13842
13843 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
13844 begin
13845 Set_Name_Table_Info (Id, Int (Val));
13846 end Set_Name_Entity_Id;
13847
13848 ---------------------
13849 -- Set_Next_Actual --
13850 ---------------------
13851
13852 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
13853 begin
13854 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
13855 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
13856 end if;
13857 end Set_Next_Actual;
13858
13859 ----------------------------------
13860 -- Set_Optimize_Alignment_Flags --
13861 ----------------------------------
13862
13863 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
13864 begin
13865 if Optimize_Alignment = 'S' then
13866 Set_Optimize_Alignment_Space (E);
13867 elsif Optimize_Alignment = 'T' then
13868 Set_Optimize_Alignment_Time (E);
13869 end if;
13870 end Set_Optimize_Alignment_Flags;
13871
13872 -----------------------
13873 -- Set_Public_Status --
13874 -----------------------
13875
13876 procedure Set_Public_Status (Id : Entity_Id) is
13877 S : constant Entity_Id := Current_Scope;
13878
13879 function Within_HSS_Or_If (E : Entity_Id) return Boolean;
13880 -- Determines if E is defined within handled statement sequence or
13881 -- an if statement, returns True if so, False otherwise.
13882
13883 ----------------------
13884 -- Within_HSS_Or_If --
13885 ----------------------
13886
13887 function Within_HSS_Or_If (E : Entity_Id) return Boolean is
13888 N : Node_Id;
13889 begin
13890 N := Declaration_Node (E);
13891 loop
13892 N := Parent (N);
13893
13894 if No (N) then
13895 return False;
13896
13897 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
13898 N_If_Statement)
13899 then
13900 return True;
13901 end if;
13902 end loop;
13903 end Within_HSS_Or_If;
13904
13905 -- Start of processing for Set_Public_Status
13906
13907 begin
13908 -- Everything in the scope of Standard is public
13909
13910 if S = Standard_Standard then
13911 Set_Is_Public (Id);
13912
13913 -- Entity is definitely not public if enclosing scope is not public
13914
13915 elsif not Is_Public (S) then
13916 return;
13917
13918 -- An object or function declaration that occurs in a handled sequence
13919 -- of statements or within an if statement is the declaration for a
13920 -- temporary object or local subprogram generated by the expander. It
13921 -- never needs to be made public and furthermore, making it public can
13922 -- cause back end problems.
13923
13924 elsif Nkind_In (Parent (Id), N_Object_Declaration,
13925 N_Function_Specification)
13926 and then Within_HSS_Or_If (Id)
13927 then
13928 return;
13929
13930 -- Entities in public packages or records are public
13931
13932 elsif Ekind (S) = E_Package or Is_Record_Type (S) then
13933 Set_Is_Public (Id);
13934
13935 -- The bounds of an entry family declaration can generate object
13936 -- declarations that are visible to the back-end, e.g. in the
13937 -- the declaration of a composite type that contains tasks.
13938
13939 elsif Is_Concurrent_Type (S)
13940 and then not Has_Completion (S)
13941 and then Nkind (Parent (Id)) = N_Object_Declaration
13942 then
13943 Set_Is_Public (Id);
13944 end if;
13945 end Set_Public_Status;
13946
13947 -----------------------------
13948 -- Set_Referenced_Modified --
13949 -----------------------------
13950
13951 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
13952 Pref : Node_Id;
13953
13954 begin
13955 -- Deal with indexed or selected component where prefix is modified
13956
13957 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
13958 Pref := Prefix (N);
13959
13960 -- If prefix is access type, then it is the designated object that is
13961 -- being modified, which means we have no entity to set the flag on.
13962
13963 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
13964 return;
13965
13966 -- Otherwise chase the prefix
13967
13968 else
13969 Set_Referenced_Modified (Pref, Out_Param);
13970 end if;
13971
13972 -- Otherwise see if we have an entity name (only other case to process)
13973
13974 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
13975 Set_Referenced_As_LHS (Entity (N), not Out_Param);
13976 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
13977 end if;
13978 end Set_Referenced_Modified;
13979
13980 ----------------------------
13981 -- Set_Scope_Is_Transient --
13982 ----------------------------
13983
13984 procedure Set_Scope_Is_Transient (V : Boolean := True) is
13985 begin
13986 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
13987 end Set_Scope_Is_Transient;
13988
13989 -------------------
13990 -- Set_Size_Info --
13991 -------------------
13992
13993 procedure Set_Size_Info (T1, T2 : Entity_Id) is
13994 begin
13995 -- We copy Esize, but not RM_Size, since in general RM_Size is
13996 -- subtype specific and does not get inherited by all subtypes.
13997
13998 Set_Esize (T1, Esize (T2));
13999 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
14000
14001 if Is_Discrete_Or_Fixed_Point_Type (T1)
14002 and then
14003 Is_Discrete_Or_Fixed_Point_Type (T2)
14004 then
14005 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
14006 end if;
14007
14008 Set_Alignment (T1, Alignment (T2));
14009 end Set_Size_Info;
14010
14011 --------------------
14012 -- Static_Boolean --
14013 --------------------
14014
14015 function Static_Boolean (N : Node_Id) return Uint is
14016 begin
14017 Analyze_And_Resolve (N, Standard_Boolean);
14018
14019 if N = Error
14020 or else Error_Posted (N)
14021 or else Etype (N) = Any_Type
14022 then
14023 return No_Uint;
14024 end if;
14025
14026 if Is_Static_Expression (N) then
14027 if not Raises_Constraint_Error (N) then
14028 return Expr_Value (N);
14029 else
14030 return No_Uint;
14031 end if;
14032
14033 elsif Etype (N) = Any_Type then
14034 return No_Uint;
14035
14036 else
14037 Flag_Non_Static_Expr
14038 ("static boolean expression required here", N);
14039 return No_Uint;
14040 end if;
14041 end Static_Boolean;
14042
14043 --------------------
14044 -- Static_Integer --
14045 --------------------
14046
14047 function Static_Integer (N : Node_Id) return Uint is
14048 begin
14049 Analyze_And_Resolve (N, Any_Integer);
14050
14051 if N = Error
14052 or else Error_Posted (N)
14053 or else Etype (N) = Any_Type
14054 then
14055 return No_Uint;
14056 end if;
14057
14058 if Is_Static_Expression (N) then
14059 if not Raises_Constraint_Error (N) then
14060 return Expr_Value (N);
14061 else
14062 return No_Uint;
14063 end if;
14064
14065 elsif Etype (N) = Any_Type then
14066 return No_Uint;
14067
14068 else
14069 Flag_Non_Static_Expr
14070 ("static integer expression required here", N);
14071 return No_Uint;
14072 end if;
14073 end Static_Integer;
14074
14075 --------------------------
14076 -- Statically_Different --
14077 --------------------------
14078
14079 function Statically_Different (E1, E2 : Node_Id) return Boolean is
14080 R1 : constant Node_Id := Get_Referenced_Object (E1);
14081 R2 : constant Node_Id := Get_Referenced_Object (E2);
14082 begin
14083 return Is_Entity_Name (R1)
14084 and then Is_Entity_Name (R2)
14085 and then Entity (R1) /= Entity (R2)
14086 and then not Is_Formal (Entity (R1))
14087 and then not Is_Formal (Entity (R2));
14088 end Statically_Different;
14089
14090 --------------------------------------
14091 -- Subject_To_Loop_Entry_Attributes --
14092 --------------------------------------
14093
14094 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is
14095 Stmt : Node_Id;
14096
14097 begin
14098 Stmt := N;
14099
14100 -- The expansion mechanism transform a loop subject to at least one
14101 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
14102 -- the conditional part.
14103
14104 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
14105 and then Nkind (Original_Node (N)) = N_Loop_Statement
14106 then
14107 Stmt := Original_Node (N);
14108 end if;
14109
14110 return
14111 Nkind (Stmt) = N_Loop_Statement
14112 and then Present (Identifier (Stmt))
14113 and then Present (Entity (Identifier (Stmt)))
14114 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
14115 end Subject_To_Loop_Entry_Attributes;
14116
14117 -----------------------------
14118 -- Subprogram_Access_Level --
14119 -----------------------------
14120
14121 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
14122 begin
14123 if Present (Alias (Subp)) then
14124 return Subprogram_Access_Level (Alias (Subp));
14125 else
14126 return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
14127 end if;
14128 end Subprogram_Access_Level;
14129
14130 -------------------------------
14131 -- Support_Atomic_Primitives --
14132 -------------------------------
14133
14134 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is
14135 Size : Int;
14136
14137 begin
14138 -- Verify the alignment of Typ is known
14139
14140 if not Known_Alignment (Typ) then
14141 return False;
14142 end if;
14143
14144 if Known_Static_Esize (Typ) then
14145 Size := UI_To_Int (Esize (Typ));
14146
14147 -- If the Esize (Object_Size) is unknown at compile time, look at the
14148 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
14149
14150 elsif Known_Static_RM_Size (Typ) then
14151 Size := UI_To_Int (RM_Size (Typ));
14152
14153 -- Otherwise, the size is considered to be unknown.
14154
14155 else
14156 return False;
14157 end if;
14158
14159 -- Check that the size of the component is 8, 16, 32 or 64 bits and that
14160 -- Typ is properly aligned.
14161
14162 case Size is
14163 when 8 | 16 | 32 | 64 =>
14164 return Size = UI_To_Int (Alignment (Typ)) * 8;
14165 when others =>
14166 return False;
14167 end case;
14168 end Support_Atomic_Primitives;
14169
14170 -----------------
14171 -- Trace_Scope --
14172 -----------------
14173
14174 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
14175 begin
14176 if Debug_Flag_W then
14177 for J in 0 .. Scope_Stack.Last loop
14178 Write_Str (" ");
14179 end loop;
14180
14181 Write_Str (Msg);
14182 Write_Name (Chars (E));
14183 Write_Str (" from ");
14184 Write_Location (Sloc (N));
14185 Write_Eol;
14186 end if;
14187 end Trace_Scope;
14188
14189 -----------------------
14190 -- Transfer_Entities --
14191 -----------------------
14192
14193 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
14194 Ent : Entity_Id := First_Entity (From);
14195
14196 begin
14197 if No (Ent) then
14198 return;
14199 end if;
14200
14201 if (Last_Entity (To)) = Empty then
14202 Set_First_Entity (To, Ent);
14203 else
14204 Set_Next_Entity (Last_Entity (To), Ent);
14205 end if;
14206
14207 Set_Last_Entity (To, Last_Entity (From));
14208
14209 while Present (Ent) loop
14210 Set_Scope (Ent, To);
14211
14212 if not Is_Public (Ent) then
14213 Set_Public_Status (Ent);
14214
14215 if Is_Public (Ent)
14216 and then Ekind (Ent) = E_Record_Subtype
14217
14218 then
14219 -- The components of the propagated Itype must be public
14220 -- as well.
14221
14222 declare
14223 Comp : Entity_Id;
14224 begin
14225 Comp := First_Entity (Ent);
14226 while Present (Comp) loop
14227 Set_Is_Public (Comp);
14228 Next_Entity (Comp);
14229 end loop;
14230 end;
14231 end if;
14232 end if;
14233
14234 Next_Entity (Ent);
14235 end loop;
14236
14237 Set_First_Entity (From, Empty);
14238 Set_Last_Entity (From, Empty);
14239 end Transfer_Entities;
14240
14241 -----------------------
14242 -- Type_Access_Level --
14243 -----------------------
14244
14245 function Type_Access_Level (Typ : Entity_Id) return Uint is
14246 Btyp : Entity_Id;
14247
14248 begin
14249 Btyp := Base_Type (Typ);
14250
14251 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
14252 -- simply use the level where the type is declared. This is true for
14253 -- stand-alone object declarations, and for anonymous access types
14254 -- associated with components the level is the same as that of the
14255 -- enclosing composite type. However, special treatment is needed for
14256 -- the cases of access parameters, return objects of an anonymous access
14257 -- type, and, in Ada 95, access discriminants of limited types.
14258
14259 if Ekind (Btyp) in Access_Kind then
14260 if Ekind (Btyp) = E_Anonymous_Access_Type then
14261
14262 -- If the type is a nonlocal anonymous access type (such as for
14263 -- an access parameter) we treat it as being declared at the
14264 -- library level to ensure that names such as X.all'access don't
14265 -- fail static accessibility checks.
14266
14267 if not Is_Local_Anonymous_Access (Typ) then
14268 return Scope_Depth (Standard_Standard);
14269
14270 -- If this is a return object, the accessibility level is that of
14271 -- the result subtype of the enclosing function. The test here is
14272 -- little complicated, because we have to account for extended
14273 -- return statements that have been rewritten as blocks, in which
14274 -- case we have to find and the Is_Return_Object attribute of the
14275 -- itype's associated object. It would be nice to find a way to
14276 -- simplify this test, but it doesn't seem worthwhile to add a new
14277 -- flag just for purposes of this test. ???
14278
14279 elsif Ekind (Scope (Btyp)) = E_Return_Statement
14280 or else
14281 (Is_Itype (Btyp)
14282 and then Nkind (Associated_Node_For_Itype (Btyp)) =
14283 N_Object_Declaration
14284 and then Is_Return_Object
14285 (Defining_Identifier
14286 (Associated_Node_For_Itype (Btyp))))
14287 then
14288 declare
14289 Scop : Entity_Id;
14290
14291 begin
14292 Scop := Scope (Scope (Btyp));
14293 while Present (Scop) loop
14294 exit when Ekind (Scop) = E_Function;
14295 Scop := Scope (Scop);
14296 end loop;
14297
14298 -- Treat the return object's type as having the level of the
14299 -- function's result subtype (as per RM05-6.5(5.3/2)).
14300
14301 return Type_Access_Level (Etype (Scop));
14302 end;
14303 end if;
14304 end if;
14305
14306 Btyp := Root_Type (Btyp);
14307
14308 -- The accessibility level of anonymous access types associated with
14309 -- discriminants is that of the current instance of the type, and
14310 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
14311
14312 -- AI-402: access discriminants have accessibility based on the
14313 -- object rather than the type in Ada 2005, so the above paragraph
14314 -- doesn't apply.
14315
14316 -- ??? Needs completion with rules from AI-416
14317
14318 if Ada_Version <= Ada_95
14319 and then Ekind (Typ) = E_Anonymous_Access_Type
14320 and then Present (Associated_Node_For_Itype (Typ))
14321 and then Nkind (Associated_Node_For_Itype (Typ)) =
14322 N_Discriminant_Specification
14323 then
14324 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
14325 end if;
14326 end if;
14327
14328 -- Return library level for a generic formal type. This is done because
14329 -- RM(10.3.2) says that "The statically deeper relationship does not
14330 -- apply to ... a descendant of a generic formal type". Rather than
14331 -- checking at each point where a static accessibility check is
14332 -- performed to see if we are dealing with a formal type, this rule is
14333 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
14334 -- return extreme values for a formal type; Deepest_Type_Access_Level
14335 -- returns Int'Last. By calling the appropriate function from among the
14336 -- two, we ensure that the static accessibility check will pass if we
14337 -- happen to run into a formal type. More specifically, we should call
14338 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
14339 -- call occurs as part of a static accessibility check and the error
14340 -- case is the case where the type's level is too shallow (as opposed
14341 -- to too deep).
14342
14343 if Is_Generic_Type (Root_Type (Btyp)) then
14344 return Scope_Depth (Standard_Standard);
14345 end if;
14346
14347 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
14348 end Type_Access_Level;
14349
14350 ------------------------------------
14351 -- Type_Without_Stream_Operation --
14352 ------------------------------------
14353
14354 function Type_Without_Stream_Operation
14355 (T : Entity_Id;
14356 Op : TSS_Name_Type := TSS_Null) return Entity_Id
14357 is
14358 BT : constant Entity_Id := Base_Type (T);
14359 Op_Missing : Boolean;
14360
14361 begin
14362 if not Restriction_Active (No_Default_Stream_Attributes) then
14363 return Empty;
14364 end if;
14365
14366 if Is_Elementary_Type (T) then
14367 if Op = TSS_Null then
14368 Op_Missing :=
14369 No (TSS (BT, TSS_Stream_Read))
14370 or else No (TSS (BT, TSS_Stream_Write));
14371
14372 else
14373 Op_Missing := No (TSS (BT, Op));
14374 end if;
14375
14376 if Op_Missing then
14377 return T;
14378 else
14379 return Empty;
14380 end if;
14381
14382 elsif Is_Array_Type (T) then
14383 return Type_Without_Stream_Operation (Component_Type (T), Op);
14384
14385 elsif Is_Record_Type (T) then
14386 declare
14387 Comp : Entity_Id;
14388 C_Typ : Entity_Id;
14389
14390 begin
14391 Comp := First_Component (T);
14392 while Present (Comp) loop
14393 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
14394
14395 if Present (C_Typ) then
14396 return C_Typ;
14397 end if;
14398
14399 Next_Component (Comp);
14400 end loop;
14401
14402 return Empty;
14403 end;
14404
14405 elsif Is_Private_Type (T)
14406 and then Present (Full_View (T))
14407 then
14408 return Type_Without_Stream_Operation (Full_View (T), Op);
14409 else
14410 return Empty;
14411 end if;
14412 end Type_Without_Stream_Operation;
14413
14414 ----------------------------
14415 -- Unique_Defining_Entity --
14416 ----------------------------
14417
14418 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
14419 begin
14420 return Unique_Entity (Defining_Entity (N));
14421 end Unique_Defining_Entity;
14422
14423 -------------------
14424 -- Unique_Entity --
14425 -------------------
14426
14427 function Unique_Entity (E : Entity_Id) return Entity_Id is
14428 U : Entity_Id := E;
14429 P : Node_Id;
14430
14431 begin
14432 case Ekind (E) is
14433 when E_Constant =>
14434 if Present (Full_View (E)) then
14435 U := Full_View (E);
14436 end if;
14437
14438 when Type_Kind =>
14439 if Present (Full_View (E)) then
14440 U := Full_View (E);
14441 end if;
14442
14443 when E_Package_Body =>
14444 P := Parent (E);
14445
14446 if Nkind (P) = N_Defining_Program_Unit_Name then
14447 P := Parent (P);
14448 end if;
14449
14450 U := Corresponding_Spec (P);
14451
14452 when E_Subprogram_Body =>
14453 P := Parent (E);
14454
14455 if Nkind (P) = N_Defining_Program_Unit_Name then
14456 P := Parent (P);
14457 end if;
14458
14459 P := Parent (P);
14460
14461 if Nkind (P) = N_Subprogram_Body_Stub then
14462 if Present (Library_Unit (P)) then
14463
14464 -- Get to the function or procedure (generic) entity through
14465 -- the body entity.
14466
14467 U :=
14468 Unique_Entity (Defining_Entity (Get_Body_From_Stub (P)));
14469 end if;
14470 else
14471 U := Corresponding_Spec (P);
14472 end if;
14473
14474 when Formal_Kind =>
14475 if Present (Spec_Entity (E)) then
14476 U := Spec_Entity (E);
14477 end if;
14478
14479 when others =>
14480 null;
14481 end case;
14482
14483 return U;
14484 end Unique_Entity;
14485
14486 -----------------
14487 -- Unique_Name --
14488 -----------------
14489
14490 function Unique_Name (E : Entity_Id) return String is
14491
14492 -- Names of E_Subprogram_Body or E_Package_Body entities are not
14493 -- reliable, as they may not include the overloading suffix. Instead,
14494 -- when looking for the name of E or one of its enclosing scope, we get
14495 -- the name of the corresponding Unique_Entity.
14496
14497 function Get_Scoped_Name (E : Entity_Id) return String;
14498 -- Return the name of E prefixed by all the names of the scopes to which
14499 -- E belongs, except for Standard.
14500
14501 ---------------------
14502 -- Get_Scoped_Name --
14503 ---------------------
14504
14505 function Get_Scoped_Name (E : Entity_Id) return String is
14506 Name : constant String := Get_Name_String (Chars (E));
14507 begin
14508 if Has_Fully_Qualified_Name (E)
14509 or else Scope (E) = Standard_Standard
14510 then
14511 return Name;
14512 else
14513 return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name;
14514 end if;
14515 end Get_Scoped_Name;
14516
14517 -- Start of processing for Unique_Name
14518
14519 begin
14520 if E = Standard_Standard then
14521 return Get_Name_String (Name_Standard);
14522
14523 elsif Scope (E) = Standard_Standard
14524 and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
14525 then
14526 return Get_Name_String (Name_Standard) & "__" &
14527 Get_Name_String (Chars (E));
14528
14529 elsif Ekind (E) = E_Enumeration_Literal then
14530 return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
14531
14532 else
14533 return Get_Scoped_Name (Unique_Entity (E));
14534 end if;
14535 end Unique_Name;
14536
14537 ---------------------
14538 -- Unit_Is_Visible --
14539 ---------------------
14540
14541 function Unit_Is_Visible (U : Entity_Id) return Boolean is
14542 Curr : constant Node_Id := Cunit (Current_Sem_Unit);
14543 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
14544
14545 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
14546 -- For a child unit, check whether unit appears in a with_clause
14547 -- of a parent.
14548
14549 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
14550 -- Scan the context clause of one compilation unit looking for a
14551 -- with_clause for the unit in question.
14552
14553 ----------------------------
14554 -- Unit_In_Parent_Context --
14555 ----------------------------
14556
14557 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
14558 begin
14559 if Unit_In_Context (Par_Unit) then
14560 return True;
14561
14562 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
14563 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
14564
14565 else
14566 return False;
14567 end if;
14568 end Unit_In_Parent_Context;
14569
14570 ---------------------
14571 -- Unit_In_Context --
14572 ---------------------
14573
14574 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
14575 Clause : Node_Id;
14576
14577 begin
14578 Clause := First (Context_Items (Comp_Unit));
14579 while Present (Clause) loop
14580 if Nkind (Clause) = N_With_Clause then
14581 if Library_Unit (Clause) = U then
14582 return True;
14583
14584 -- The with_clause may denote a renaming of the unit we are
14585 -- looking for, eg. Text_IO which renames Ada.Text_IO.
14586
14587 elsif
14588 Renamed_Entity (Entity (Name (Clause))) =
14589 Defining_Entity (Unit (U))
14590 then
14591 return True;
14592 end if;
14593 end if;
14594
14595 Next (Clause);
14596 end loop;
14597
14598 return False;
14599 end Unit_In_Context;
14600
14601 -- Start of processing for Unit_Is_Visible
14602
14603 begin
14604 -- The currrent unit is directly visible
14605
14606 if Curr = U then
14607 return True;
14608
14609 elsif Unit_In_Context (Curr) then
14610 return True;
14611
14612 -- If the current unit is a body, check the context of the spec
14613
14614 elsif Nkind (Unit (Curr)) = N_Package_Body
14615 or else
14616 (Nkind (Unit (Curr)) = N_Subprogram_Body
14617 and then not Acts_As_Spec (Unit (Curr)))
14618 then
14619 if Unit_In_Context (Library_Unit (Curr)) then
14620 return True;
14621 end if;
14622 end if;
14623
14624 -- If the spec is a child unit, examine the parents
14625
14626 if Is_Child_Unit (Curr_Entity) then
14627 if Nkind (Unit (Curr)) in N_Unit_Body then
14628 return
14629 Unit_In_Parent_Context
14630 (Parent_Spec (Unit (Library_Unit (Curr))));
14631 else
14632 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
14633 end if;
14634
14635 else
14636 return False;
14637 end if;
14638 end Unit_Is_Visible;
14639
14640 ------------------------------
14641 -- Universal_Interpretation --
14642 ------------------------------
14643
14644 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
14645 Index : Interp_Index;
14646 It : Interp;
14647
14648 begin
14649 -- The argument may be a formal parameter of an operator or subprogram
14650 -- with multiple interpretations, or else an expression for an actual.
14651
14652 if Nkind (Opnd) = N_Defining_Identifier
14653 or else not Is_Overloaded (Opnd)
14654 then
14655 if Etype (Opnd) = Universal_Integer
14656 or else Etype (Opnd) = Universal_Real
14657 then
14658 return Etype (Opnd);
14659 else
14660 return Empty;
14661 end if;
14662
14663 else
14664 Get_First_Interp (Opnd, Index, It);
14665 while Present (It.Typ) loop
14666 if It.Typ = Universal_Integer
14667 or else It.Typ = Universal_Real
14668 then
14669 return It.Typ;
14670 end if;
14671
14672 Get_Next_Interp (Index, It);
14673 end loop;
14674
14675 return Empty;
14676 end if;
14677 end Universal_Interpretation;
14678
14679 ---------------
14680 -- Unqualify --
14681 ---------------
14682
14683 function Unqualify (Expr : Node_Id) return Node_Id is
14684 begin
14685 -- Recurse to handle unlikely case of multiple levels of qualification
14686
14687 if Nkind (Expr) = N_Qualified_Expression then
14688 return Unqualify (Expression (Expr));
14689
14690 -- Normal case, not a qualified expression
14691
14692 else
14693 return Expr;
14694 end if;
14695 end Unqualify;
14696
14697 -----------------------
14698 -- Visible_Ancestors --
14699 -----------------------
14700
14701 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
14702 List_1 : Elist_Id;
14703 List_2 : Elist_Id;
14704 Elmt : Elmt_Id;
14705
14706 begin
14707 pragma Assert (Is_Record_Type (Typ)
14708 and then Is_Tagged_Type (Typ));
14709
14710 -- Collect all the parents and progenitors of Typ. If the full-view of
14711 -- private parents and progenitors is available then it is used to
14712 -- generate the list of visible ancestors; otherwise their partial
14713 -- view is added to the resulting list.
14714
14715 Collect_Parents
14716 (T => Typ,
14717 List => List_1,
14718 Use_Full_View => True);
14719
14720 Collect_Interfaces
14721 (T => Typ,
14722 Ifaces_List => List_2,
14723 Exclude_Parents => True,
14724 Use_Full_View => True);
14725
14726 -- Join the two lists. Avoid duplications because an interface may
14727 -- simultaneously be parent and progenitor of a type.
14728
14729 Elmt := First_Elmt (List_2);
14730 while Present (Elmt) loop
14731 Append_Unique_Elmt (Node (Elmt), List_1);
14732 Next_Elmt (Elmt);
14733 end loop;
14734
14735 return List_1;
14736 end Visible_Ancestors;
14737
14738 ----------------------
14739 -- Within_Init_Proc --
14740 ----------------------
14741
14742 function Within_Init_Proc return Boolean is
14743 S : Entity_Id;
14744
14745 begin
14746 S := Current_Scope;
14747 while not Is_Overloadable (S) loop
14748 if S = Standard_Standard then
14749 return False;
14750 else
14751 S := Scope (S);
14752 end if;
14753 end loop;
14754
14755 return Is_Init_Proc (S);
14756 end Within_Init_Proc;
14757
14758 ----------------
14759 -- Wrong_Type --
14760 ----------------
14761
14762 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
14763 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
14764 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
14765
14766 Matching_Field : Entity_Id;
14767 -- Entity to give a more precise suggestion on how to write a one-
14768 -- element positional aggregate.
14769
14770 function Has_One_Matching_Field return Boolean;
14771 -- Determines if Expec_Type is a record type with a single component or
14772 -- discriminant whose type matches the found type or is one dimensional
14773 -- array whose component type matches the found type. In the case of
14774 -- one discriminant, we ignore the variant parts. That's not accurate,
14775 -- but good enough for the warning.
14776
14777 ----------------------------
14778 -- Has_One_Matching_Field --
14779 ----------------------------
14780
14781 function Has_One_Matching_Field return Boolean is
14782 E : Entity_Id;
14783
14784 begin
14785 Matching_Field := Empty;
14786
14787 if Is_Array_Type (Expec_Type)
14788 and then Number_Dimensions (Expec_Type) = 1
14789 and then
14790 Covers (Etype (Component_Type (Expec_Type)), Found_Type)
14791 then
14792 -- Use type name if available. This excludes multidimensional
14793 -- arrays and anonymous arrays.
14794
14795 if Comes_From_Source (Expec_Type) then
14796 Matching_Field := Expec_Type;
14797
14798 -- For an assignment, use name of target
14799
14800 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
14801 and then Is_Entity_Name (Name (Parent (Expr)))
14802 then
14803 Matching_Field := Entity (Name (Parent (Expr)));
14804 end if;
14805
14806 return True;
14807
14808 elsif not Is_Record_Type (Expec_Type) then
14809 return False;
14810
14811 else
14812 E := First_Entity (Expec_Type);
14813 loop
14814 if No (E) then
14815 return False;
14816
14817 elsif not Ekind_In (E, E_Discriminant, E_Component)
14818 or else Nam_In (Chars (E), Name_uTag, Name_uParent)
14819 then
14820 Next_Entity (E);
14821
14822 else
14823 exit;
14824 end if;
14825 end loop;
14826
14827 if not Covers (Etype (E), Found_Type) then
14828 return False;
14829
14830 elsif Present (Next_Entity (E))
14831 and then (Ekind (E) = E_Component
14832 or else Ekind (Next_Entity (E)) = E_Discriminant)
14833 then
14834 return False;
14835
14836 else
14837 Matching_Field := E;
14838 return True;
14839 end if;
14840 end if;
14841 end Has_One_Matching_Field;
14842
14843 -- Start of processing for Wrong_Type
14844
14845 begin
14846 -- Don't output message if either type is Any_Type, or if a message
14847 -- has already been posted for this node. We need to do the latter
14848 -- check explicitly (it is ordinarily done in Errout), because we
14849 -- are using ! to force the output of the error messages.
14850
14851 if Expec_Type = Any_Type
14852 or else Found_Type = Any_Type
14853 or else Error_Posted (Expr)
14854 then
14855 return;
14856
14857 -- If one of the types is a Taft-Amendment type and the other it its
14858 -- completion, it must be an illegal use of a TAT in the spec, for
14859 -- which an error was already emitted. Avoid cascaded errors.
14860
14861 elsif Is_Incomplete_Type (Expec_Type)
14862 and then Has_Completion_In_Body (Expec_Type)
14863 and then Full_View (Expec_Type) = Etype (Expr)
14864 then
14865 return;
14866
14867 elsif Is_Incomplete_Type (Etype (Expr))
14868 and then Has_Completion_In_Body (Etype (Expr))
14869 and then Full_View (Etype (Expr)) = Expec_Type
14870 then
14871 return;
14872
14873 -- In an instance, there is an ongoing problem with completion of
14874 -- type derived from private types. Their structure is what Gigi
14875 -- expects, but the Etype is the parent type rather than the
14876 -- derived private type itself. Do not flag error in this case. The
14877 -- private completion is an entity without a parent, like an Itype.
14878 -- Similarly, full and partial views may be incorrect in the instance.
14879 -- There is no simple way to insure that it is consistent ???
14880
14881 elsif In_Instance then
14882 if Etype (Etype (Expr)) = Etype (Expected_Type)
14883 and then
14884 (Has_Private_Declaration (Expected_Type)
14885 or else Has_Private_Declaration (Etype (Expr)))
14886 and then No (Parent (Expected_Type))
14887 then
14888 return;
14889 end if;
14890 end if;
14891
14892 -- An interesting special check. If the expression is parenthesized
14893 -- and its type corresponds to the type of the sole component of the
14894 -- expected record type, or to the component type of the expected one
14895 -- dimensional array type, then assume we have a bad aggregate attempt.
14896
14897 if Nkind (Expr) in N_Subexpr
14898 and then Paren_Count (Expr) /= 0
14899 and then Has_One_Matching_Field
14900 then
14901 Error_Msg_N ("positional aggregate cannot have one component", Expr);
14902 if Present (Matching_Field) then
14903 if Is_Array_Type (Expec_Type) then
14904 Error_Msg_NE
14905 ("\write instead `&''First ='> ...`", Expr, Matching_Field);
14906
14907 else
14908 Error_Msg_NE
14909 ("\write instead `& ='> ...`", Expr, Matching_Field);
14910 end if;
14911 end if;
14912
14913 -- Another special check, if we are looking for a pool-specific access
14914 -- type and we found an E_Access_Attribute_Type, then we have the case
14915 -- of an Access attribute being used in a context which needs a pool-
14916 -- specific type, which is never allowed. The one extra check we make
14917 -- is that the expected designated type covers the Found_Type.
14918
14919 elsif Is_Access_Type (Expec_Type)
14920 and then Ekind (Found_Type) = E_Access_Attribute_Type
14921 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
14922 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
14923 and then Covers
14924 (Designated_Type (Expec_Type), Designated_Type (Found_Type))
14925 then
14926 Error_Msg_N -- CODEFIX
14927 ("result must be general access type!", Expr);
14928 Error_Msg_NE -- CODEFIX
14929 ("add ALL to }!", Expr, Expec_Type);
14930
14931 -- Another special check, if the expected type is an integer type,
14932 -- but the expression is of type System.Address, and the parent is
14933 -- an addition or subtraction operation whose left operand is the
14934 -- expression in question and whose right operand is of an integral
14935 -- type, then this is an attempt at address arithmetic, so give
14936 -- appropriate message.
14937
14938 elsif Is_Integer_Type (Expec_Type)
14939 and then Is_RTE (Found_Type, RE_Address)
14940 and then (Nkind (Parent (Expr)) = N_Op_Add
14941 or else
14942 Nkind (Parent (Expr)) = N_Op_Subtract)
14943 and then Expr = Left_Opnd (Parent (Expr))
14944 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
14945 then
14946 Error_Msg_N
14947 ("address arithmetic not predefined in package System",
14948 Parent (Expr));
14949 Error_Msg_N
14950 ("\possible missing with/use of System.Storage_Elements",
14951 Parent (Expr));
14952 return;
14953
14954 -- If the expected type is an anonymous access type, as for access
14955 -- parameters and discriminants, the error is on the designated types.
14956
14957 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
14958 if Comes_From_Source (Expec_Type) then
14959 Error_Msg_NE ("expected}!", Expr, Expec_Type);
14960 else
14961 Error_Msg_NE
14962 ("expected an access type with designated}",
14963 Expr, Designated_Type (Expec_Type));
14964 end if;
14965
14966 if Is_Access_Type (Found_Type)
14967 and then not Comes_From_Source (Found_Type)
14968 then
14969 Error_Msg_NE
14970 ("\\found an access type with designated}!",
14971 Expr, Designated_Type (Found_Type));
14972 else
14973 if From_With_Type (Found_Type) then
14974 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
14975 Error_Msg_Qual_Level := 99;
14976 Error_Msg_NE -- CODEFIX
14977 ("\\missing `WITH &;", Expr, Scope (Found_Type));
14978 Error_Msg_Qual_Level := 0;
14979 else
14980 Error_Msg_NE ("found}!", Expr, Found_Type);
14981 end if;
14982 end if;
14983
14984 -- Normal case of one type found, some other type expected
14985
14986 else
14987 -- If the names of the two types are the same, see if some number
14988 -- of levels of qualification will help. Don't try more than three
14989 -- levels, and if we get to standard, it's no use (and probably
14990 -- represents an error in the compiler) Also do not bother with
14991 -- internal scope names.
14992
14993 declare
14994 Expec_Scope : Entity_Id;
14995 Found_Scope : Entity_Id;
14996
14997 begin
14998 Expec_Scope := Expec_Type;
14999 Found_Scope := Found_Type;
15000
15001 for Levels in Int range 0 .. 3 loop
15002 if Chars (Expec_Scope) /= Chars (Found_Scope) then
15003 Error_Msg_Qual_Level := Levels;
15004 exit;
15005 end if;
15006
15007 Expec_Scope := Scope (Expec_Scope);
15008 Found_Scope := Scope (Found_Scope);
15009
15010 exit when Expec_Scope = Standard_Standard
15011 or else Found_Scope = Standard_Standard
15012 or else not Comes_From_Source (Expec_Scope)
15013 or else not Comes_From_Source (Found_Scope);
15014 end loop;
15015 end;
15016
15017 if Is_Record_Type (Expec_Type)
15018 and then Present (Corresponding_Remote_Type (Expec_Type))
15019 then
15020 Error_Msg_NE ("expected}!", Expr,
15021 Corresponding_Remote_Type (Expec_Type));
15022 else
15023 Error_Msg_NE ("expected}!", Expr, Expec_Type);
15024 end if;
15025
15026 if Is_Entity_Name (Expr)
15027 and then Is_Package_Or_Generic_Package (Entity (Expr))
15028 then
15029 Error_Msg_N ("\\found package name!", Expr);
15030
15031 elsif Is_Entity_Name (Expr)
15032 and then
15033 (Ekind (Entity (Expr)) = E_Procedure
15034 or else
15035 Ekind (Entity (Expr)) = E_Generic_Procedure)
15036 then
15037 if Ekind (Expec_Type) = E_Access_Subprogram_Type then
15038 Error_Msg_N
15039 ("found procedure name, possibly missing Access attribute!",
15040 Expr);
15041 else
15042 Error_Msg_N
15043 ("\\found procedure name instead of function!", Expr);
15044 end if;
15045
15046 elsif Nkind (Expr) = N_Function_Call
15047 and then Ekind (Expec_Type) = E_Access_Subprogram_Type
15048 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
15049 and then No (Parameter_Associations (Expr))
15050 then
15051 Error_Msg_N
15052 ("found function name, possibly missing Access attribute!",
15053 Expr);
15054
15055 -- Catch common error: a prefix or infix operator which is not
15056 -- directly visible because the type isn't.
15057
15058 elsif Nkind (Expr) in N_Op
15059 and then Is_Overloaded (Expr)
15060 and then not Is_Immediately_Visible (Expec_Type)
15061 and then not Is_Potentially_Use_Visible (Expec_Type)
15062 and then not In_Use (Expec_Type)
15063 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
15064 then
15065 Error_Msg_N
15066 ("operator of the type is not directly visible!", Expr);
15067
15068 elsif Ekind (Found_Type) = E_Void
15069 and then Present (Parent (Found_Type))
15070 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
15071 then
15072 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
15073
15074 else
15075 Error_Msg_NE ("\\found}!", Expr, Found_Type);
15076 end if;
15077
15078 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
15079 -- of the same modular type, and (M1 and M2) = 0 was intended.
15080
15081 if Expec_Type = Standard_Boolean
15082 and then Is_Modular_Integer_Type (Found_Type)
15083 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
15084 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
15085 then
15086 declare
15087 Op : constant Node_Id := Right_Opnd (Parent (Expr));
15088 L : constant Node_Id := Left_Opnd (Op);
15089 R : constant Node_Id := Right_Opnd (Op);
15090 begin
15091 -- The case for the message is when the left operand of the
15092 -- comparison is the same modular type, or when it is an
15093 -- integer literal (or other universal integer expression),
15094 -- which would have been typed as the modular type if the
15095 -- parens had been there.
15096
15097 if (Etype (L) = Found_Type
15098 or else
15099 Etype (L) = Universal_Integer)
15100 and then Is_Integer_Type (Etype (R))
15101 then
15102 Error_Msg_N
15103 ("\\possible missing parens for modular operation", Expr);
15104 end if;
15105 end;
15106 end if;
15107
15108 -- Reset error message qualification indication
15109
15110 Error_Msg_Qual_Level := 0;
15111 end if;
15112 end Wrong_Type;
15113
15114 end Sem_Util;
Mirror of the offical gcc git repository hosted at gcc.gnu.org