File : sem_util.adb
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-2016, 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 Treepr; -- ???For debugging code below
27
28 with Aspects; use Aspects;
29 with Atree; use Atree;
30 with Casing; use Casing;
31 with Checks; use Checks;
32 with Debug; use Debug;
33 with Elists; use Elists;
34 with Errout; use Errout;
35 with Exp_Ch11; use Exp_Ch11;
36 with Exp_Disp; use Exp_Disp;
37 with Exp_Util; use Exp_Util;
38 with Fname; use Fname;
39 with Freeze; use Freeze;
40 with Ghost; use Ghost;
41 with Lib; use Lib;
42 with Lib.Xref; use Lib.Xref;
43 with Namet.Sp; use Namet.Sp;
44 with Nlists; use Nlists;
45 with Nmake; use Nmake;
46 with Output; use Output;
47 with Restrict; use Restrict;
48 with Rident; use Rident;
49 with Rtsfind; use Rtsfind;
50 with Sem; use Sem;
51 with Sem_Aux; use Sem_Aux;
52 with Sem_Attr; use Sem_Attr;
53 with Sem_Ch6; use Sem_Ch6;
54 with Sem_Ch8; use Sem_Ch8;
55 with Sem_Ch13; use Sem_Ch13;
56 with Sem_Disp; use Sem_Disp;
57 with Sem_Eval; use Sem_Eval;
58 with Sem_Prag; use Sem_Prag;
59 with Sem_Res; use Sem_Res;
60 with Sem_Warn; use Sem_Warn;
61 with Sem_Type; use Sem_Type;
62 with Sinfo; use Sinfo;
63 with Sinput; use Sinput;
64 with Stand; use Stand;
65 with Style;
66 with Stringt; use Stringt;
67 with Targparm; use Targparm;
68 with Tbuild; use Tbuild;
69 with Ttypes; use Ttypes;
70 with Uname; use Uname;
71
72 with GNAT.HTable; use GNAT.HTable;
73
74 package body Sem_Util is
75
76 ----------------------------------------
77 -- Global Variables for New_Copy_Tree --
78 ----------------------------------------
79
80 -- These global variables are used by New_Copy_Tree. See description of the
81 -- body of this subprogram for details. Global variables can be safely used
82 -- by New_Copy_Tree, since there is no case of a recursive call from the
83 -- processing inside New_Copy_Tree.
84
85 NCT_Hash_Threshold : constant := 20;
86 -- If there are more than this number of pairs of entries in the map, then
87 -- Hash_Tables_Used will be set, and the hash tables will be initialized
88 -- and used for the searches.
89
90 NCT_Hash_Tables_Used : Boolean := False;
91 -- Set to True if hash tables are in use
92
93 NCT_Table_Entries : Nat := 0;
94 -- Count entries in table to see if threshold is reached
95
96 NCT_Hash_Table_Setup : Boolean := False;
97 -- Set to True if hash table contains data. We set this True if we setup
98 -- the hash table with data, and leave it set permanently from then on,
99 -- this is a signal that second and subsequent users of the hash table
100 -- must clear the old entries before reuse.
101
102 subtype NCT_Header_Num is Int range 0 .. 511;
103 -- Defines range of headers in hash tables (512 headers)
104
105 -----------------------
106 -- Local Subprograms --
107 -----------------------
108
109 function Build_Component_Subtype
110 (C : List_Id;
111 Loc : Source_Ptr;
112 T : Entity_Id) return Node_Id;
113 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
114 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
115 -- Loc is the source location, T is the original subtype.
116
117 function Has_Enabled_Property
118 (Item_Id : Entity_Id;
119 Property : Name_Id) return Boolean;
120 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
121 -- Determine whether an abstract state or a variable denoted by entity
122 -- Item_Id has enabled property Property.
123
124 function Has_Null_Extension (T : Entity_Id) return Boolean;
125 -- T is a derived tagged type. Check whether the type extension is null.
126 -- If the parent type is fully initialized, T can be treated as such.
127
128 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
129 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
130 -- with discriminants whose default values are static, examine only the
131 -- components in the selected variant to determine whether all of them
132 -- have a default.
133
134 ------------------------------
135 -- Abstract_Interface_List --
136 ------------------------------
137
138 function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
139 Nod : Node_Id;
140
141 begin
142 if Is_Concurrent_Type (Typ) then
143
144 -- If we are dealing with a synchronized subtype, go to the base
145 -- type, whose declaration has the interface list.
146
147 -- Shouldn't this be Declaration_Node???
148
149 Nod := Parent (Base_Type (Typ));
150
151 if Nkind (Nod) = N_Full_Type_Declaration then
152 return Empty_List;
153 end if;
154
155 elsif Ekind (Typ) = E_Record_Type_With_Private then
156 if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
157 Nod := Type_Definition (Parent (Typ));
158
159 elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
160 if Present (Full_View (Typ))
161 and then
162 Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration
163 then
164 Nod := Type_Definition (Parent (Full_View (Typ)));
165
166 -- If the full-view is not available we cannot do anything else
167 -- here (the source has errors).
168
169 else
170 return Empty_List;
171 end if;
172
173 -- Support for generic formals with interfaces is still missing ???
174
175 elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
176 return Empty_List;
177
178 else
179 pragma Assert
180 (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
181 Nod := Parent (Typ);
182 end if;
183
184 elsif Ekind (Typ) = E_Record_Subtype then
185 Nod := Type_Definition (Parent (Etype (Typ)));
186
187 elsif Ekind (Typ) = E_Record_Subtype_With_Private then
188
189 -- Recurse, because parent may still be a private extension. Also
190 -- note that the full view of the subtype or the full view of its
191 -- base type may (both) be unavailable.
192
193 return Abstract_Interface_List (Etype (Typ));
194
195 else pragma Assert ((Ekind (Typ)) = E_Record_Type);
196 if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
197 Nod := Formal_Type_Definition (Parent (Typ));
198 else
199 Nod := Type_Definition (Parent (Typ));
200 end if;
201 end if;
202
203 return Interface_List (Nod);
204 end Abstract_Interface_List;
205
206 --------------------------------
207 -- Add_Access_Type_To_Process --
208 --------------------------------
209
210 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
211 L : Elist_Id;
212
213 begin
214 Ensure_Freeze_Node (E);
215 L := Access_Types_To_Process (Freeze_Node (E));
216
217 if No (L) then
218 L := New_Elmt_List;
219 Set_Access_Types_To_Process (Freeze_Node (E), L);
220 end if;
221
222 Append_Elmt (A, L);
223 end Add_Access_Type_To_Process;
224
225 --------------------------
226 -- Add_Block_Identifier --
227 --------------------------
228
229 procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is
230 Loc : constant Source_Ptr := Sloc (N);
231
232 begin
233 pragma Assert (Nkind (N) = N_Block_Statement);
234
235 -- The block already has a label, return its entity
236
237 if Present (Identifier (N)) then
238 Id := Entity (Identifier (N));
239
240 -- Create a new block label and set its attributes
241
242 else
243 Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
244 Set_Etype (Id, Standard_Void_Type);
245 Set_Parent (Id, N);
246
247 Set_Identifier (N, New_Occurrence_Of (Id, Loc));
248 Set_Block_Node (Id, Identifier (N));
249 end if;
250 end Add_Block_Identifier;
251
252 ----------------------------
253 -- Add_Global_Declaration --
254 ----------------------------
255
256 procedure Add_Global_Declaration (N : Node_Id) is
257 Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
258
259 begin
260 if No (Declarations (Aux_Node)) then
261 Set_Declarations (Aux_Node, New_List);
262 end if;
263
264 Append_To (Declarations (Aux_Node), N);
265 Analyze (N);
266 end Add_Global_Declaration;
267
268 --------------------------------
269 -- Address_Integer_Convert_OK --
270 --------------------------------
271
272 function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is
273 begin
274 if Allow_Integer_Address
275 and then ((Is_Descendant_Of_Address (T1)
276 and then Is_Private_Type (T1)
277 and then Is_Integer_Type (T2))
278 or else
279 (Is_Descendant_Of_Address (T2)
280 and then Is_Private_Type (T2)
281 and then Is_Integer_Type (T1)))
282 then
283 return True;
284 else
285 return False;
286 end if;
287 end Address_Integer_Convert_OK;
288
289 -------------------
290 -- Address_Value --
291 -------------------
292
293 function Address_Value (N : Node_Id) return Node_Id is
294 Expr : Node_Id := N;
295
296 begin
297 loop
298 -- For constant, get constant expression
299
300 if Is_Entity_Name (Expr)
301 and then Ekind (Entity (Expr)) = E_Constant
302 then
303 Expr := Constant_Value (Entity (Expr));
304
305 -- For unchecked conversion, get result to convert
306
307 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
308 Expr := Expression (Expr);
309
310 -- For (common case) of To_Address call, get argument
311
312 elsif Nkind (Expr) = N_Function_Call
313 and then Is_Entity_Name (Name (Expr))
314 and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
315 then
316 Expr := First (Parameter_Associations (Expr));
317
318 if Nkind (Expr) = N_Parameter_Association then
319 Expr := Explicit_Actual_Parameter (Expr);
320 end if;
321
322 -- We finally have the real expression
323
324 else
325 exit;
326 end if;
327 end loop;
328
329 return Expr;
330 end Address_Value;
331
332 -----------------
333 -- Addressable --
334 -----------------
335
336 -- For now, just 8/16/32/64
337
338 function Addressable (V : Uint) return Boolean is
339 begin
340 return V = Uint_8 or else
341 V = Uint_16 or else
342 V = Uint_32 or else
343 V = Uint_64;
344 end Addressable;
345
346 function Addressable (V : Int) return Boolean is
347 begin
348 return V = 8 or else
349 V = 16 or else
350 V = 32 or else
351 V = 64;
352 end Addressable;
353
354 ---------------------------------
355 -- Aggregate_Constraint_Checks --
356 ---------------------------------
357
358 procedure Aggregate_Constraint_Checks
359 (Exp : Node_Id;
360 Check_Typ : Entity_Id)
361 is
362 Exp_Typ : constant Entity_Id := Etype (Exp);
363
364 begin
365 if Raises_Constraint_Error (Exp) then
366 return;
367 end if;
368
369 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
370 -- component's type to force the appropriate accessibility checks.
371
372 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to
373 -- force the corresponding run-time check
374
375 if Is_Access_Type (Check_Typ)
376 and then Is_Local_Anonymous_Access (Check_Typ)
377 then
378 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
379 Analyze_And_Resolve (Exp, Check_Typ);
380 Check_Unset_Reference (Exp);
381 end if;
382
383 -- What follows is really expansion activity, so check that expansion
384 -- is on and is allowed. In GNATprove mode, we also want check flags to
385 -- be added in the tree, so that the formal verification can rely on
386 -- those to be present. In GNATprove mode for formal verification, some
387 -- treatment typically only done during expansion needs to be performed
388 -- on the tree, but it should not be applied inside generics. Otherwise,
389 -- this breaks the name resolution mechanism for generic instances.
390
391 if not Expander_Active
392 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
393 then
394 return;
395 end if;
396
397 if Is_Access_Type (Check_Typ)
398 and then Can_Never_Be_Null (Check_Typ)
399 and then not Can_Never_Be_Null (Exp_Typ)
400 then
401 Install_Null_Excluding_Check (Exp);
402 end if;
403
404 -- First check if we have to insert discriminant checks
405
406 if Has_Discriminants (Exp_Typ) then
407 Apply_Discriminant_Check (Exp, Check_Typ);
408
409 -- Next emit length checks for array aggregates
410
411 elsif Is_Array_Type (Exp_Typ) then
412 Apply_Length_Check (Exp, Check_Typ);
413
414 -- Finally emit scalar and string checks. If we are dealing with a
415 -- scalar literal we need to check by hand because the Etype of
416 -- literals is not necessarily correct.
417
418 elsif Is_Scalar_Type (Exp_Typ)
419 and then Compile_Time_Known_Value (Exp)
420 then
421 if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
422 Apply_Compile_Time_Constraint_Error
423 (Exp, "value not in range of}??", CE_Range_Check_Failed,
424 Ent => Base_Type (Check_Typ),
425 Typ => Base_Type (Check_Typ));
426
427 elsif Is_Out_Of_Range (Exp, Check_Typ) then
428 Apply_Compile_Time_Constraint_Error
429 (Exp, "value not in range of}??", CE_Range_Check_Failed,
430 Ent => Check_Typ,
431 Typ => Check_Typ);
432
433 elsif not Range_Checks_Suppressed (Check_Typ) then
434 Apply_Scalar_Range_Check (Exp, Check_Typ);
435 end if;
436
437 -- Verify that target type is also scalar, to prevent view anomalies
438 -- in instantiations.
439
440 elsif (Is_Scalar_Type (Exp_Typ)
441 or else Nkind (Exp) = N_String_Literal)
442 and then Is_Scalar_Type (Check_Typ)
443 and then Exp_Typ /= Check_Typ
444 then
445 if Is_Entity_Name (Exp)
446 and then Ekind (Entity (Exp)) = E_Constant
447 then
448 -- If expression is a constant, it is worthwhile checking whether
449 -- it is a bound of the type.
450
451 if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
452 and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
453 or else
454 (Is_Entity_Name (Type_High_Bound (Check_Typ))
455 and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
456 then
457 return;
458
459 else
460 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
461 Analyze_And_Resolve (Exp, Check_Typ);
462 Check_Unset_Reference (Exp);
463 end if;
464
465 -- Could use a comment on this case ???
466
467 else
468 Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
469 Analyze_And_Resolve (Exp, Check_Typ);
470 Check_Unset_Reference (Exp);
471 end if;
472
473 end if;
474 end Aggregate_Constraint_Checks;
475
476 -----------------------
477 -- Alignment_In_Bits --
478 -----------------------
479
480 function Alignment_In_Bits (E : Entity_Id) return Uint is
481 begin
482 return Alignment (E) * System_Storage_Unit;
483 end Alignment_In_Bits;
484
485 --------------------------------------
486 -- All_Composite_Constraints_Static --
487 --------------------------------------
488
489 function All_Composite_Constraints_Static
490 (Constr : Node_Id) return Boolean
491 is
492 begin
493 if No (Constr) or else Error_Posted (Constr) then
494 return True;
495 end if;
496
497 case Nkind (Constr) is
498 when N_Subexpr =>
499 if Nkind (Constr) in N_Has_Entity
500 and then Present (Entity (Constr))
501 then
502 if Is_Type (Entity (Constr)) then
503 return
504 not Is_Discrete_Type (Entity (Constr))
505 or else Is_OK_Static_Subtype (Entity (Constr));
506 end if;
507
508 elsif Nkind (Constr) = N_Range then
509 return
510 Is_OK_Static_Expression (Low_Bound (Constr))
511 and then
512 Is_OK_Static_Expression (High_Bound (Constr));
513
514 elsif Nkind (Constr) = N_Attribute_Reference
515 and then Attribute_Name (Constr) = Name_Range
516 then
517 return
518 Is_OK_Static_Expression
519 (Type_Low_Bound (Etype (Prefix (Constr))))
520 and then
521 Is_OK_Static_Expression
522 (Type_High_Bound (Etype (Prefix (Constr))));
523 end if;
524
525 return
526 not Present (Etype (Constr)) -- previous error
527 or else not Is_Discrete_Type (Etype (Constr))
528 or else Is_OK_Static_Expression (Constr);
529
530 when N_Discriminant_Association =>
531 return All_Composite_Constraints_Static (Expression (Constr));
532
533 when N_Range_Constraint =>
534 return
535 All_Composite_Constraints_Static (Range_Expression (Constr));
536
537 when N_Index_Or_Discriminant_Constraint =>
538 declare
539 One_Cstr : Entity_Id;
540 begin
541 One_Cstr := First (Constraints (Constr));
542 while Present (One_Cstr) loop
543 if not All_Composite_Constraints_Static (One_Cstr) then
544 return False;
545 end if;
546
547 Next (One_Cstr);
548 end loop;
549 end;
550
551 return True;
552
553 when N_Subtype_Indication =>
554 return
555 All_Composite_Constraints_Static (Subtype_Mark (Constr))
556 and then
557 All_Composite_Constraints_Static (Constraint (Constr));
558
559 when others =>
560 raise Program_Error;
561 end case;
562 end All_Composite_Constraints_Static;
563
564 ---------------------------------
565 -- Append_Inherited_Subprogram --
566 ---------------------------------
567
568 procedure Append_Inherited_Subprogram (S : Entity_Id) is
569 Par : constant Entity_Id := Alias (S);
570 -- The parent subprogram
571
572 Scop : constant Entity_Id := Scope (Par);
573 -- The scope of definition of the parent subprogram
574
575 Typ : constant Entity_Id := Defining_Entity (Parent (S));
576 -- The derived type of which S is a primitive operation
577
578 Decl : Node_Id;
579 Next_E : Entity_Id;
580
581 begin
582 if Ekind (Current_Scope) = E_Package
583 and then In_Private_Part (Current_Scope)
584 and then Has_Private_Declaration (Typ)
585 and then Is_Tagged_Type (Typ)
586 and then Scop = Current_Scope
587 then
588 -- The inherited operation is available at the earliest place after
589 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only
590 -- relevant for type extensions. If the parent operation appears
591 -- after the type extension, the operation is not visible.
592
593 Decl := First
594 (Visible_Declarations
595 (Package_Specification (Current_Scope)));
596 while Present (Decl) loop
597 if Nkind (Decl) = N_Private_Extension_Declaration
598 and then Defining_Entity (Decl) = Typ
599 then
600 if Sloc (Decl) > Sloc (Par) then
601 Next_E := Next_Entity (Par);
602 Set_Next_Entity (Par, S);
603 Set_Next_Entity (S, Next_E);
604 return;
605
606 else
607 exit;
608 end if;
609 end if;
610
611 Next (Decl);
612 end loop;
613 end if;
614
615 -- If partial view is not a type extension, or it appears before the
616 -- subprogram declaration, insert normally at end of entity list.
617
618 Append_Entity (S, Current_Scope);
619 end Append_Inherited_Subprogram;
620
621 -----------------------------------------
622 -- Apply_Compile_Time_Constraint_Error --
623 -----------------------------------------
624
625 procedure Apply_Compile_Time_Constraint_Error
626 (N : Node_Id;
627 Msg : String;
628 Reason : RT_Exception_Code;
629 Ent : Entity_Id := Empty;
630 Typ : Entity_Id := Empty;
631 Loc : Source_Ptr := No_Location;
632 Rep : Boolean := True;
633 Warn : Boolean := False)
634 is
635 Stat : constant Boolean := Is_Static_Expression (N);
636 R_Stat : constant Node_Id :=
637 Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
638 Rtyp : Entity_Id;
639
640 begin
641 if No (Typ) then
642 Rtyp := Etype (N);
643 else
644 Rtyp := Typ;
645 end if;
646
647 Discard_Node
648 (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
649
650 -- In GNATprove mode, do not replace the node with an exception raised.
651 -- In such a case, either the call to Compile_Time_Constraint_Error
652 -- issues an error which stops analysis, or it issues a warning in
653 -- a few cases where a suitable check flag is set for GNATprove to
654 -- generate a check message.
655
656 if not Rep or GNATprove_Mode then
657 return;
658 end if;
659
660 -- Now we replace the node by an N_Raise_Constraint_Error node
661 -- This does not need reanalyzing, so set it as analyzed now.
662
663 Rewrite (N, R_Stat);
664 Set_Analyzed (N, True);
665
666 Set_Etype (N, Rtyp);
667 Set_Raises_Constraint_Error (N);
668
669 -- Now deal with possible local raise handling
670
671 Possible_Local_Raise (N, Standard_Constraint_Error);
672
673 -- If the original expression was marked as static, the result is
674 -- still marked as static, but the Raises_Constraint_Error flag is
675 -- always set so that further static evaluation is not attempted.
676
677 if Stat then
678 Set_Is_Static_Expression (N);
679 end if;
680 end Apply_Compile_Time_Constraint_Error;
681
682 ---------------------------
683 -- Async_Readers_Enabled --
684 ---------------------------
685
686 function Async_Readers_Enabled (Id : Entity_Id) return Boolean is
687 begin
688 return Has_Enabled_Property (Id, Name_Async_Readers);
689 end Async_Readers_Enabled;
690
691 ---------------------------
692 -- Async_Writers_Enabled --
693 ---------------------------
694
695 function Async_Writers_Enabled (Id : Entity_Id) return Boolean is
696 begin
697 return Has_Enabled_Property (Id, Name_Async_Writers);
698 end Async_Writers_Enabled;
699
700 --------------------------------------
701 -- Available_Full_View_Of_Component --
702 --------------------------------------
703
704 function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
705 ST : constant Entity_Id := Scope (T);
706 SCT : constant Entity_Id := Scope (Component_Type (T));
707 begin
708 return In_Open_Scopes (ST)
709 and then In_Open_Scopes (SCT)
710 and then Scope_Depth (ST) >= Scope_Depth (SCT);
711 end Available_Full_View_Of_Component;
712
713 -------------------
714 -- Bad_Attribute --
715 -------------------
716
717 procedure Bad_Attribute
718 (N : Node_Id;
719 Nam : Name_Id;
720 Warn : Boolean := False)
721 is
722 begin
723 Error_Msg_Warn := Warn;
724 Error_Msg_N ("unrecognized attribute&<<", N);
725
726 -- Check for possible misspelling
727
728 Error_Msg_Name_1 := First_Attribute_Name;
729 while Error_Msg_Name_1 <= Last_Attribute_Name loop
730 if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
731 Error_Msg_N -- CODEFIX
732 ("\possible misspelling of %<<", N);
733 exit;
734 end if;
735
736 Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
737 end loop;
738 end Bad_Attribute;
739
740 --------------------------------
741 -- Bad_Predicated_Subtype_Use --
742 --------------------------------
743
744 procedure Bad_Predicated_Subtype_Use
745 (Msg : String;
746 N : Node_Id;
747 Typ : Entity_Id;
748 Suggest_Static : Boolean := False)
749 is
750 Gen : Entity_Id;
751
752 begin
753 -- Avoid cascaded errors
754
755 if Error_Posted (N) then
756 return;
757 end if;
758
759 if Inside_A_Generic then
760 Gen := Current_Scope;
761 while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop
762 Gen := Scope (Gen);
763 end loop;
764
765 if No (Gen) then
766 return;
767 end if;
768
769 if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then
770 Set_No_Predicate_On_Actual (Typ);
771 end if;
772
773 elsif Has_Predicates (Typ) then
774 if Is_Generic_Actual_Type (Typ) then
775
776 -- The restriction on loop parameters is only that the type
777 -- should have no dynamic predicates.
778
779 if Nkind (Parent (N)) = N_Loop_Parameter_Specification
780 and then not Has_Dynamic_Predicate_Aspect (Typ)
781 and then Is_OK_Static_Subtype (Typ)
782 then
783 return;
784 end if;
785
786 Gen := Current_Scope;
787 while not Is_Generic_Instance (Gen) loop
788 Gen := Scope (Gen);
789 end loop;
790
791 pragma Assert (Present (Gen));
792
793 if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then
794 Error_Msg_Warn := SPARK_Mode /= On;
795 Error_Msg_FE (Msg & "<<", N, Typ);
796 Error_Msg_F ("\Program_Error [<<", N);
797
798 Insert_Action (N,
799 Make_Raise_Program_Error (Sloc (N),
800 Reason => PE_Bad_Predicated_Generic_Type));
801
802 else
803 Error_Msg_FE (Msg & "<<", N, Typ);
804 end if;
805
806 else
807 Error_Msg_FE (Msg, N, Typ);
808 end if;
809
810 -- Emit an optional suggestion on how to remedy the error if the
811 -- context warrants it.
812
813 if Suggest_Static and then Has_Static_Predicate (Typ) then
814 Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
815 end if;
816 end if;
817 end Bad_Predicated_Subtype_Use;
818
819 -----------------------------------------
820 -- Bad_Unordered_Enumeration_Reference --
821 -----------------------------------------
822
823 function Bad_Unordered_Enumeration_Reference
824 (N : Node_Id;
825 T : Entity_Id) return Boolean
826 is
827 begin
828 return Is_Enumeration_Type (T)
829 and then Warn_On_Unordered_Enumeration_Type
830 and then not Is_Generic_Type (T)
831 and then Comes_From_Source (N)
832 and then not Has_Pragma_Ordered (T)
833 and then not In_Same_Extended_Unit (N, T);
834 end Bad_Unordered_Enumeration_Reference;
835
836 --------------------------
837 -- Build_Actual_Subtype --
838 --------------------------
839
840 function Build_Actual_Subtype
841 (T : Entity_Id;
842 N : Node_Or_Entity_Id) return Node_Id
843 is
844 Loc : Source_Ptr;
845 -- Normally Sloc (N), but may point to corresponding body in some cases
846
847 Constraints : List_Id;
848 Decl : Node_Id;
849 Discr : Entity_Id;
850 Hi : Node_Id;
851 Lo : Node_Id;
852 Subt : Entity_Id;
853 Disc_Type : Entity_Id;
854 Obj : Node_Id;
855
856 begin
857 Loc := Sloc (N);
858
859 if Nkind (N) = N_Defining_Identifier then
860 Obj := New_Occurrence_Of (N, Loc);
861
862 -- If this is a formal parameter of a subprogram declaration, and
863 -- we are compiling the body, we want the declaration for the
864 -- actual subtype to carry the source position of the body, to
865 -- prevent anomalies in gdb when stepping through the code.
866
867 if Is_Formal (N) then
868 declare
869 Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
870 begin
871 if Nkind (Decl) = N_Subprogram_Declaration
872 and then Present (Corresponding_Body (Decl))
873 then
874 Loc := Sloc (Corresponding_Body (Decl));
875 end if;
876 end;
877 end if;
878
879 else
880 Obj := N;
881 end if;
882
883 if Is_Array_Type (T) then
884 Constraints := New_List;
885 for J in 1 .. Number_Dimensions (T) loop
886
887 -- Build an array subtype declaration with the nominal subtype and
888 -- the bounds of the actual. Add the declaration in front of the
889 -- local declarations for the subprogram, for analysis before any
890 -- reference to the formal in the body.
891
892 Lo :=
893 Make_Attribute_Reference (Loc,
894 Prefix =>
895 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
896 Attribute_Name => Name_First,
897 Expressions => New_List (
898 Make_Integer_Literal (Loc, J)));
899
900 Hi :=
901 Make_Attribute_Reference (Loc,
902 Prefix =>
903 Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
904 Attribute_Name => Name_Last,
905 Expressions => New_List (
906 Make_Integer_Literal (Loc, J)));
907
908 Append (Make_Range (Loc, Lo, Hi), Constraints);
909 end loop;
910
911 -- If the type has unknown discriminants there is no constrained
912 -- subtype to build. This is never called for a formal or for a
913 -- lhs, so returning the type is ok ???
914
915 elsif Has_Unknown_Discriminants (T) then
916 return T;
917
918 else
919 Constraints := New_List;
920
921 -- Type T is a generic derived type, inherit the discriminants from
922 -- the parent type.
923
924 if Is_Private_Type (T)
925 and then No (Full_View (T))
926
927 -- T was flagged as an error if it was declared as a formal
928 -- derived type with known discriminants. In this case there
929 -- is no need to look at the parent type since T already carries
930 -- its own discriminants.
931
932 and then not Error_Posted (T)
933 then
934 Disc_Type := Etype (Base_Type (T));
935 else
936 Disc_Type := T;
937 end if;
938
939 Discr := First_Discriminant (Disc_Type);
940 while Present (Discr) loop
941 Append_To (Constraints,
942 Make_Selected_Component (Loc,
943 Prefix =>
944 Duplicate_Subexpr_No_Checks (Obj),
945 Selector_Name => New_Occurrence_Of (Discr, Loc)));
946 Next_Discriminant (Discr);
947 end loop;
948 end if;
949
950 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
951 Set_Is_Internal (Subt);
952
953 Decl :=
954 Make_Subtype_Declaration (Loc,
955 Defining_Identifier => Subt,
956 Subtype_Indication =>
957 Make_Subtype_Indication (Loc,
958 Subtype_Mark => New_Occurrence_Of (T, Loc),
959 Constraint =>
960 Make_Index_Or_Discriminant_Constraint (Loc,
961 Constraints => Constraints)));
962
963 Mark_Rewrite_Insertion (Decl);
964 return Decl;
965 end Build_Actual_Subtype;
966
967 ---------------------------------------
968 -- Build_Actual_Subtype_Of_Component --
969 ---------------------------------------
970
971 function Build_Actual_Subtype_Of_Component
972 (T : Entity_Id;
973 N : Node_Id) return Node_Id
974 is
975 Loc : constant Source_Ptr := Sloc (N);
976 P : constant Node_Id := Prefix (N);
977 D : Elmt_Id;
978 Id : Node_Id;
979 Index_Typ : Entity_Id;
980
981 Desig_Typ : Entity_Id;
982 -- This is either a copy of T, or if T is an access type, then it is
983 -- the directly designated type of this access type.
984
985 function Build_Actual_Array_Constraint return List_Id;
986 -- If one or more of the bounds of the component depends on
987 -- discriminants, build actual constraint using the discriminants
988 -- of the prefix.
989
990 function Build_Actual_Record_Constraint return List_Id;
991 -- Similar to previous one, for discriminated components constrained
992 -- by the discriminant of the enclosing object.
993
994 -----------------------------------
995 -- Build_Actual_Array_Constraint --
996 -----------------------------------
997
998 function Build_Actual_Array_Constraint return List_Id is
999 Constraints : constant List_Id := New_List;
1000 Indx : Node_Id;
1001 Hi : Node_Id;
1002 Lo : Node_Id;
1003 Old_Hi : Node_Id;
1004 Old_Lo : Node_Id;
1005
1006 begin
1007 Indx := First_Index (Desig_Typ);
1008 while Present (Indx) loop
1009 Old_Lo := Type_Low_Bound (Etype (Indx));
1010 Old_Hi := Type_High_Bound (Etype (Indx));
1011
1012 if Denotes_Discriminant (Old_Lo) then
1013 Lo :=
1014 Make_Selected_Component (Loc,
1015 Prefix => New_Copy_Tree (P),
1016 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
1017
1018 else
1019 Lo := New_Copy_Tree (Old_Lo);
1020
1021 -- The new bound will be reanalyzed in the enclosing
1022 -- declaration. For literal bounds that come from a type
1023 -- declaration, the type of the context must be imposed, so
1024 -- insure that analysis will take place. For non-universal
1025 -- types this is not strictly necessary.
1026
1027 Set_Analyzed (Lo, False);
1028 end if;
1029
1030 if Denotes_Discriminant (Old_Hi) then
1031 Hi :=
1032 Make_Selected_Component (Loc,
1033 Prefix => New_Copy_Tree (P),
1034 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
1035
1036 else
1037 Hi := New_Copy_Tree (Old_Hi);
1038 Set_Analyzed (Hi, False);
1039 end if;
1040
1041 Append (Make_Range (Loc, Lo, Hi), Constraints);
1042 Next_Index (Indx);
1043 end loop;
1044
1045 return Constraints;
1046 end Build_Actual_Array_Constraint;
1047
1048 ------------------------------------
1049 -- Build_Actual_Record_Constraint --
1050 ------------------------------------
1051
1052 function Build_Actual_Record_Constraint return List_Id is
1053 Constraints : constant List_Id := New_List;
1054 D : Elmt_Id;
1055 D_Val : Node_Id;
1056
1057 begin
1058 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
1059 while Present (D) loop
1060 if Denotes_Discriminant (Node (D)) then
1061 D_Val := Make_Selected_Component (Loc,
1062 Prefix => New_Copy_Tree (P),
1063 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
1064
1065 else
1066 D_Val := New_Copy_Tree (Node (D));
1067 end if;
1068
1069 Append (D_Val, Constraints);
1070 Next_Elmt (D);
1071 end loop;
1072
1073 return Constraints;
1074 end Build_Actual_Record_Constraint;
1075
1076 -- Start of processing for Build_Actual_Subtype_Of_Component
1077
1078 begin
1079 -- Why the test for Spec_Expression mode here???
1080
1081 if In_Spec_Expression then
1082 return Empty;
1083
1084 -- More comments for the rest of this body would be good ???
1085
1086 elsif Nkind (N) = N_Explicit_Dereference then
1087 if Is_Composite_Type (T)
1088 and then not Is_Constrained (T)
1089 and then not (Is_Class_Wide_Type (T)
1090 and then Is_Constrained (Root_Type (T)))
1091 and then not Has_Unknown_Discriminants (T)
1092 then
1093 -- If the type of the dereference is already constrained, it is an
1094 -- actual subtype.
1095
1096 if Is_Array_Type (Etype (N))
1097 and then Is_Constrained (Etype (N))
1098 then
1099 return Empty;
1100 else
1101 Remove_Side_Effects (P);
1102 return Build_Actual_Subtype (T, N);
1103 end if;
1104 else
1105 return Empty;
1106 end if;
1107 end if;
1108
1109 if Ekind (T) = E_Access_Subtype then
1110 Desig_Typ := Designated_Type (T);
1111 else
1112 Desig_Typ := T;
1113 end if;
1114
1115 if Ekind (Desig_Typ) = E_Array_Subtype then
1116 Id := First_Index (Desig_Typ);
1117 while Present (Id) loop
1118 Index_Typ := Underlying_Type (Etype (Id));
1119
1120 if Denotes_Discriminant (Type_Low_Bound (Index_Typ))
1121 or else
1122 Denotes_Discriminant (Type_High_Bound (Index_Typ))
1123 then
1124 Remove_Side_Effects (P);
1125 return
1126 Build_Component_Subtype
1127 (Build_Actual_Array_Constraint, Loc, Base_Type (T));
1128 end if;
1129
1130 Next_Index (Id);
1131 end loop;
1132
1133 elsif Is_Composite_Type (Desig_Typ)
1134 and then Has_Discriminants (Desig_Typ)
1135 and then not Has_Unknown_Discriminants (Desig_Typ)
1136 then
1137 if Is_Private_Type (Desig_Typ)
1138 and then No (Discriminant_Constraint (Desig_Typ))
1139 then
1140 Desig_Typ := Full_View (Desig_Typ);
1141 end if;
1142
1143 D := First_Elmt (Discriminant_Constraint (Desig_Typ));
1144 while Present (D) loop
1145 if Denotes_Discriminant (Node (D)) then
1146 Remove_Side_Effects (P);
1147 return
1148 Build_Component_Subtype (
1149 Build_Actual_Record_Constraint, Loc, Base_Type (T));
1150 end if;
1151
1152 Next_Elmt (D);
1153 end loop;
1154 end if;
1155
1156 -- If none of the above, the actual and nominal subtypes are the same
1157
1158 return Empty;
1159 end Build_Actual_Subtype_Of_Component;
1160
1161 -----------------------------
1162 -- Build_Component_Subtype --
1163 -----------------------------
1164
1165 function Build_Component_Subtype
1166 (C : List_Id;
1167 Loc : Source_Ptr;
1168 T : Entity_Id) return Node_Id
1169 is
1170 Subt : Entity_Id;
1171 Decl : Node_Id;
1172
1173 begin
1174 -- Unchecked_Union components do not require component subtypes
1175
1176 if Is_Unchecked_Union (T) then
1177 return Empty;
1178 end if;
1179
1180 Subt := Make_Temporary (Loc, 'S');
1181 Set_Is_Internal (Subt);
1182
1183 Decl :=
1184 Make_Subtype_Declaration (Loc,
1185 Defining_Identifier => Subt,
1186 Subtype_Indication =>
1187 Make_Subtype_Indication (Loc,
1188 Subtype_Mark => New_Occurrence_Of (Base_Type (T), Loc),
1189 Constraint =>
1190 Make_Index_Or_Discriminant_Constraint (Loc,
1191 Constraints => C)));
1192
1193 Mark_Rewrite_Insertion (Decl);
1194 return Decl;
1195 end Build_Component_Subtype;
1196
1197 ----------------------------------
1198 -- Build_Default_Init_Cond_Call --
1199 ----------------------------------
1200
1201 function Build_Default_Init_Cond_Call
1202 (Loc : Source_Ptr;
1203 Obj_Id : Entity_Id;
1204 Typ : Entity_Id) return Node_Id
1205 is
1206 Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
1207 Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
1208
1209 begin
1210 return
1211 Make_Procedure_Call_Statement (Loc,
1212 Name => New_Occurrence_Of (Proc_Id, Loc),
1213 Parameter_Associations => New_List (
1214 Make_Unchecked_Type_Conversion (Loc,
1215 Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
1216 Expression => New_Occurrence_Of (Obj_Id, Loc))));
1217 end Build_Default_Init_Cond_Call;
1218
1219 ----------------------------------------------
1220 -- Build_Default_Init_Cond_Procedure_Bodies --
1221 ----------------------------------------------
1222
1223 procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id) is
1224 procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id);
1225 -- If type Typ is subject to pragma Default_Initial_Condition, build the
1226 -- body of the procedure which verifies the assumption of the pragma at
1227 -- run time. The generated body is added after the type declaration.
1228
1229 --------------------------------------------
1230 -- Build_Default_Init_Cond_Procedure_Body --
1231 --------------------------------------------
1232
1233 procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is
1234 Param_Id : Entity_Id;
1235 -- The entity of the sole formal parameter of the default initial
1236 -- condition procedure.
1237
1238 procedure Replace_Type_Reference (N : Node_Id);
1239 -- Replace a single reference to type Typ with a reference to formal
1240 -- parameter Param_Id.
1241
1242 ----------------------------
1243 -- Replace_Type_Reference --
1244 ----------------------------
1245
1246 procedure Replace_Type_Reference (N : Node_Id) is
1247 begin
1248 Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N)));
1249 end Replace_Type_Reference;
1250
1251 procedure Replace_Type_References is
1252 new Replace_Type_References_Generic (Replace_Type_Reference);
1253
1254 -- Local variables
1255
1256 Loc : constant Source_Ptr := Sloc (Typ);
1257 Prag : constant Node_Id :=
1258 Get_Pragma (Typ, Pragma_Default_Initial_Condition);
1259 Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
1260 Body_Decl : Node_Id;
1261 Expr : Node_Id;
1262 Spec_Decl : Node_Id;
1263 Stmt : Node_Id;
1264
1265 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
1266
1267 -- Start of processing for Build_Default_Init_Cond_Procedure_Body
1268
1269 begin
1270 -- The procedure should be generated only for [sub]types subject to
1271 -- pragma Default_Initial_Condition. Types that inherit the pragma do
1272 -- not get this specialized procedure.
1273
1274 pragma Assert (Has_Default_Init_Cond (Typ));
1275 pragma Assert (Present (Prag));
1276
1277 -- Nothing to do if the spec was not built. This occurs when the
1278 -- expression of the Default_Initial_Condition is missing or is
1279 -- null.
1280
1281 if No (Proc_Id) then
1282 return;
1283
1284 -- Nothing to do if the body was already built
1285
1286 elsif Present (Corresponding_Body (Unit_Declaration_Node (Proc_Id)))
1287 then
1288 return;
1289 end if;
1290
1291 -- The related type may be subject to pragma Ghost. Set the mode now
1292 -- to ensure that the analysis and expansion produce Ghost nodes.
1293
1294 Set_Ghost_Mode_From_Entity (Typ);
1295
1296 Param_Id := First_Formal (Proc_Id);
1297
1298 -- The pragma has an argument. Note that the argument is analyzed
1299 -- after all references to the current instance of the type are
1300 -- replaced.
1301
1302 if Present (Pragma_Argument_Associations (Prag)) then
1303 Expr :=
1304 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
1305
1306 if Nkind (Expr) = N_Null then
1307 Stmt := Make_Null_Statement (Loc);
1308
1309 -- Preserve the original argument of the pragma by replicating it.
1310 -- Replace all references to the current instance of the type with
1311 -- references to the formal parameter.
1312
1313 else
1314 Expr := New_Copy_Tree (Expr);
1315 Replace_Type_References (Expr, Typ);
1316
1317 -- Generate:
1318 -- pragma Check (Default_Initial_Condition, <Expr>);
1319
1320 Stmt :=
1321 Make_Pragma (Loc,
1322 Pragma_Identifier =>
1323 Make_Identifier (Loc, Name_Check),
1324
1325 Pragma_Argument_Associations => New_List (
1326 Make_Pragma_Argument_Association (Loc,
1327 Expression =>
1328 Make_Identifier (Loc,
1329 Chars => Name_Default_Initial_Condition)),
1330 Make_Pragma_Argument_Association (Loc,
1331 Expression => Expr)));
1332 end if;
1333
1334 -- Otherwise the pragma appears without an argument
1335
1336 else
1337 Stmt := Make_Null_Statement (Loc);
1338 end if;
1339
1340 -- Generate:
1341 -- procedure <Typ>Default_Init_Cond (I : <Typ>) is
1342 -- begin
1343 -- <Stmt>;
1344 -- end <Typ>Default_Init_Cond;
1345
1346 Spec_Decl := Unit_Declaration_Node (Proc_Id);
1347 Body_Decl :=
1348 Make_Subprogram_Body (Loc,
1349 Specification =>
1350 Copy_Separate_Tree (Specification (Spec_Decl)),
1351 Declarations => Empty_List,
1352 Handled_Statement_Sequence =>
1353 Make_Handled_Sequence_Of_Statements (Loc,
1354 Statements => New_List (Stmt)));
1355
1356 -- Link the spec and body of the default initial condition procedure
1357 -- to prevent the generation of a duplicate body.
1358
1359 Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl));
1360 Set_Corresponding_Spec (Body_Decl, Proc_Id);
1361
1362 Insert_After_And_Analyze (Declaration_Node (Typ), Body_Decl);
1363 Ghost_Mode := Save_Ghost_Mode;
1364 end Build_Default_Init_Cond_Procedure_Body;
1365
1366 -- Local variables
1367
1368 Decl : Node_Id;
1369 Typ : Entity_Id;
1370
1371 -- Start of processing for Build_Default_Init_Cond_Procedure_Bodies
1372
1373 begin
1374 -- Inspect the private declarations looking for [sub]type declarations
1375
1376 Decl := First (Priv_Decls);
1377 while Present (Decl) loop
1378 if Nkind_In (Decl, N_Full_Type_Declaration,
1379 N_Subtype_Declaration)
1380 then
1381 Typ := Defining_Entity (Decl);
1382
1383 -- Guard against partially decorate types due to previous errors
1384
1385 if Is_Type (Typ) then
1386
1387 -- If the type is subject to pragma Default_Initial_Condition,
1388 -- generate the body of the internal procedure which verifies
1389 -- the assertion of the pragma at run time.
1390
1391 if Has_Default_Init_Cond (Typ) then
1392 Build_Default_Init_Cond_Procedure_Body (Typ);
1393
1394 -- A derived type inherits the default initial condition
1395 -- procedure from its parent type.
1396
1397 elsif Has_Inherited_Default_Init_Cond (Typ) then
1398 Inherit_Default_Init_Cond_Procedure (Typ);
1399 end if;
1400 end if;
1401 end if;
1402
1403 Next (Decl);
1404 end loop;
1405 end Build_Default_Init_Cond_Procedure_Bodies;
1406
1407 ---------------------------------------------------
1408 -- Build_Default_Init_Cond_Procedure_Declaration --
1409 ---------------------------------------------------
1410
1411 procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id) is
1412 Loc : constant Source_Ptr := Sloc (Typ);
1413 Prag : constant Node_Id :=
1414 Get_Pragma (Typ, Pragma_Default_Initial_Condition);
1415
1416 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
1417
1418 Args : List_Id;
1419 Proc_Id : Entity_Id;
1420
1421 begin
1422 -- The procedure should be generated only for types subject to pragma
1423 -- Default_Initial_Condition. Types that inherit the pragma do not get
1424 -- this specialized procedure.
1425
1426 pragma Assert (Has_Default_Init_Cond (Typ));
1427 pragma Assert (Present (Prag));
1428
1429 Args := Pragma_Argument_Associations (Prag);
1430
1431 -- Nothing to do if default initial condition procedure already built
1432
1433 if Present (Default_Init_Cond_Procedure (Typ)) then
1434 return;
1435
1436 -- Nothing to do if the default initial condition appears without an
1437 -- expression.
1438
1439 elsif No (Args) then
1440 return;
1441
1442 -- Nothing to do if the expression of the default initial condition is
1443 -- null.
1444
1445 elsif Nkind (Get_Pragma_Arg (First (Args))) = N_Null then
1446 return;
1447 end if;
1448
1449 -- The related type may be subject to pragma Ghost. Set the mode now to
1450 -- ensure that the analysis and expansion produce Ghost nodes.
1451
1452 Set_Ghost_Mode_From_Entity (Typ);
1453
1454 Proc_Id :=
1455 Make_Defining_Identifier (Loc,
1456 Chars => New_External_Name (Chars (Typ), "Default_Init_Cond"));
1457
1458 -- Associate default initial condition procedure with the private type
1459
1460 Set_Ekind (Proc_Id, E_Procedure);
1461 Set_Is_Default_Init_Cond_Procedure (Proc_Id);
1462 Set_Default_Init_Cond_Procedure (Typ, Proc_Id);
1463
1464 -- Mark the default initial condition procedure explicitly as Ghost
1465 -- because it does not come from source.
1466
1467 if Ghost_Mode > None then
1468 Set_Is_Ghost_Entity (Proc_Id);
1469 end if;
1470
1471 -- Generate:
1472 -- procedure <Typ>Default_Init_Cond (Inn : <Typ>);
1473
1474 Insert_After_And_Analyze (Prag,
1475 Make_Subprogram_Declaration (Loc,
1476 Specification =>
1477 Make_Procedure_Specification (Loc,
1478 Defining_Unit_Name => Proc_Id,
1479 Parameter_Specifications => New_List (
1480 Make_Parameter_Specification (Loc,
1481 Defining_Identifier => Make_Temporary (Loc, 'I'),
1482 Parameter_Type => New_Occurrence_Of (Typ, Loc))))));
1483
1484 Ghost_Mode := Save_Ghost_Mode;
1485 end Build_Default_Init_Cond_Procedure_Declaration;
1486
1487 ---------------------------
1488 -- Build_Default_Subtype --
1489 ---------------------------
1490
1491 function Build_Default_Subtype
1492 (T : Entity_Id;
1493 N : Node_Id) return Entity_Id
1494 is
1495 Loc : constant Source_Ptr := Sloc (N);
1496 Disc : Entity_Id;
1497
1498 Bas : Entity_Id;
1499 -- The base type that is to be constrained by the defaults
1500
1501 begin
1502 if not Has_Discriminants (T) or else Is_Constrained (T) then
1503 return T;
1504 end if;
1505
1506 Bas := Base_Type (T);
1507
1508 -- If T is non-private but its base type is private, this is the
1509 -- completion of a subtype declaration whose parent type is private
1510 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
1511 -- are to be found in the full view of the base. Check that the private
1512 -- status of T and its base differ.
1513
1514 if Is_Private_Type (Bas)
1515 and then not Is_Private_Type (T)
1516 and then Present (Full_View (Bas))
1517 then
1518 Bas := Full_View (Bas);
1519 end if;
1520
1521 Disc := First_Discriminant (T);
1522
1523 if No (Discriminant_Default_Value (Disc)) then
1524 return T;
1525 end if;
1526
1527 declare
1528 Act : constant Entity_Id := Make_Temporary (Loc, 'S');
1529 Constraints : constant List_Id := New_List;
1530 Decl : Node_Id;
1531
1532 begin
1533 while Present (Disc) loop
1534 Append_To (Constraints,
1535 New_Copy_Tree (Discriminant_Default_Value (Disc)));
1536 Next_Discriminant (Disc);
1537 end loop;
1538
1539 Decl :=
1540 Make_Subtype_Declaration (Loc,
1541 Defining_Identifier => Act,
1542 Subtype_Indication =>
1543 Make_Subtype_Indication (Loc,
1544 Subtype_Mark => New_Occurrence_Of (Bas, Loc),
1545 Constraint =>
1546 Make_Index_Or_Discriminant_Constraint (Loc,
1547 Constraints => Constraints)));
1548
1549 Insert_Action (N, Decl);
1550
1551 -- If the context is a component declaration the subtype declaration
1552 -- will be analyzed when the enclosing type is frozen, otherwise do
1553 -- it now.
1554
1555 if Ekind (Current_Scope) /= E_Record_Type then
1556 Analyze (Decl);
1557 end if;
1558
1559 return Act;
1560 end;
1561 end Build_Default_Subtype;
1562
1563 --------------------------------------------
1564 -- Build_Discriminal_Subtype_Of_Component --
1565 --------------------------------------------
1566
1567 function Build_Discriminal_Subtype_Of_Component
1568 (T : Entity_Id) return Node_Id
1569 is
1570 Loc : constant Source_Ptr := Sloc (T);
1571 D : Elmt_Id;
1572 Id : Node_Id;
1573
1574 function Build_Discriminal_Array_Constraint return List_Id;
1575 -- If one or more of the bounds of the component depends on
1576 -- discriminants, build actual constraint using the discriminants
1577 -- of the prefix.
1578
1579 function Build_Discriminal_Record_Constraint return List_Id;
1580 -- Similar to previous one, for discriminated components constrained by
1581 -- the discriminant of the enclosing object.
1582
1583 ----------------------------------------
1584 -- Build_Discriminal_Array_Constraint --
1585 ----------------------------------------
1586
1587 function Build_Discriminal_Array_Constraint return List_Id is
1588 Constraints : constant List_Id := New_List;
1589 Indx : Node_Id;
1590 Hi : Node_Id;
1591 Lo : Node_Id;
1592 Old_Hi : Node_Id;
1593 Old_Lo : Node_Id;
1594
1595 begin
1596 Indx := First_Index (T);
1597 while Present (Indx) loop
1598 Old_Lo := Type_Low_Bound (Etype (Indx));
1599 Old_Hi := Type_High_Bound (Etype (Indx));
1600
1601 if Denotes_Discriminant (Old_Lo) then
1602 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
1603
1604 else
1605 Lo := New_Copy_Tree (Old_Lo);
1606 end if;
1607
1608 if Denotes_Discriminant (Old_Hi) then
1609 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
1610
1611 else
1612 Hi := New_Copy_Tree (Old_Hi);
1613 end if;
1614
1615 Append (Make_Range (Loc, Lo, Hi), Constraints);
1616 Next_Index (Indx);
1617 end loop;
1618
1619 return Constraints;
1620 end Build_Discriminal_Array_Constraint;
1621
1622 -----------------------------------------
1623 -- Build_Discriminal_Record_Constraint --
1624 -----------------------------------------
1625
1626 function Build_Discriminal_Record_Constraint return List_Id is
1627 Constraints : constant List_Id := New_List;
1628 D : Elmt_Id;
1629 D_Val : Node_Id;
1630
1631 begin
1632 D := First_Elmt (Discriminant_Constraint (T));
1633 while Present (D) loop
1634 if Denotes_Discriminant (Node (D)) then
1635 D_Val :=
1636 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
1637 else
1638 D_Val := New_Copy_Tree (Node (D));
1639 end if;
1640
1641 Append (D_Val, Constraints);
1642 Next_Elmt (D);
1643 end loop;
1644
1645 return Constraints;
1646 end Build_Discriminal_Record_Constraint;
1647
1648 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1649
1650 begin
1651 if Ekind (T) = E_Array_Subtype then
1652 Id := First_Index (T);
1653 while Present (Id) loop
1654 if Denotes_Discriminant (Type_Low_Bound (Etype (Id)))
1655 or else
1656 Denotes_Discriminant (Type_High_Bound (Etype (Id)))
1657 then
1658 return Build_Component_Subtype
1659 (Build_Discriminal_Array_Constraint, Loc, T);
1660 end if;
1661
1662 Next_Index (Id);
1663 end loop;
1664
1665 elsif Ekind (T) = E_Record_Subtype
1666 and then Has_Discriminants (T)
1667 and then not Has_Unknown_Discriminants (T)
1668 then
1669 D := First_Elmt (Discriminant_Constraint (T));
1670 while Present (D) loop
1671 if Denotes_Discriminant (Node (D)) then
1672 return Build_Component_Subtype
1673 (Build_Discriminal_Record_Constraint, Loc, T);
1674 end if;
1675
1676 Next_Elmt (D);
1677 end loop;
1678 end if;
1679
1680 -- If none of the above, the actual and nominal subtypes are the same
1681
1682 return Empty;
1683 end Build_Discriminal_Subtype_Of_Component;
1684
1685 ------------------------------
1686 -- Build_Elaboration_Entity --
1687 ------------------------------
1688
1689 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
1690 Loc : constant Source_Ptr := Sloc (N);
1691 Decl : Node_Id;
1692 Elab_Ent : Entity_Id;
1693
1694 procedure Set_Package_Name (Ent : Entity_Id);
1695 -- Given an entity, sets the fully qualified name of the entity in
1696 -- Name_Buffer, with components separated by double underscores. This
1697 -- is a recursive routine that climbs the scope chain to Standard.
1698
1699 ----------------------
1700 -- Set_Package_Name --
1701 ----------------------
1702
1703 procedure Set_Package_Name (Ent : Entity_Id) is
1704 begin
1705 if Scope (Ent) /= Standard_Standard then
1706 Set_Package_Name (Scope (Ent));
1707
1708 declare
1709 Nam : constant String := Get_Name_String (Chars (Ent));
1710 begin
1711 Name_Buffer (Name_Len + 1) := '_';
1712 Name_Buffer (Name_Len + 2) := '_';
1713 Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
1714 Name_Len := Name_Len + Nam'Length + 2;
1715 end;
1716
1717 else
1718 Get_Name_String (Chars (Ent));
1719 end if;
1720 end Set_Package_Name;
1721
1722 -- Start of processing for Build_Elaboration_Entity
1723
1724 begin
1725 -- Ignore call if already constructed
1726
1727 if Present (Elaboration_Entity (Spec_Id)) then
1728 return;
1729
1730 -- Ignore in ASIS mode, elaboration entity is not in source and plays
1731 -- no role in analysis.
1732
1733 elsif ASIS_Mode then
1734 return;
1735
1736 -- See if we need elaboration entity.
1737
1738 -- We always need an elaboration entity when preserving control flow, as
1739 -- we want to remain explicit about the unit's elaboration order.
1740
1741 elsif Opt.Suppress_Control_Flow_Optimizations then
1742 null;
1743
1744 -- We always need an elaboration entity for the dynamic elaboration
1745 -- model, since it is needed to properly generate the PE exception for
1746 -- access before elaboration.
1747
1748 elsif Dynamic_Elaboration_Checks then
1749 null;
1750
1751 -- For the static model, we don't need the elaboration counter if this
1752 -- unit is sure to have no elaboration code, since that means there
1753 -- is no elaboration unit to be called. Note that we can't just decide
1754 -- after the fact by looking to see whether there was elaboration code,
1755 -- because that's too late to make this decision.
1756
1757 elsif Restriction_Active (No_Elaboration_Code) then
1758 return;
1759
1760 -- Similarly, for the static model, we can skip the elaboration counter
1761 -- if we have the No_Multiple_Elaboration restriction, since for the
1762 -- static model, that's the only purpose of the counter (to avoid
1763 -- multiple elaboration).
1764
1765 elsif Restriction_Active (No_Multiple_Elaboration) then
1766 return;
1767 end if;
1768
1769 -- Here we need the elaboration entity
1770
1771 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
1772 -- name with dots replaced by double underscore. We have to manually
1773 -- construct this name, since it will be elaborated in the outer scope,
1774 -- and thus will not have the unit name automatically prepended.
1775
1776 Set_Package_Name (Spec_Id);
1777 Add_Str_To_Name_Buffer ("_E");
1778
1779 -- Create elaboration counter
1780
1781 Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
1782 Set_Elaboration_Entity (Spec_Id, Elab_Ent);
1783
1784 Decl :=
1785 Make_Object_Declaration (Loc,
1786 Defining_Identifier => Elab_Ent,
1787 Object_Definition =>
1788 New_Occurrence_Of (Standard_Short_Integer, Loc),
1789 Expression => Make_Integer_Literal (Loc, Uint_0));
1790
1791 Push_Scope (Standard_Standard);
1792 Add_Global_Declaration (Decl);
1793 Pop_Scope;
1794
1795 -- Reset True_Constant indication, since we will indeed assign a value
1796 -- to the variable in the binder main. We also kill the Current_Value
1797 -- and Last_Assignment fields for the same reason.
1798
1799 Set_Is_True_Constant (Elab_Ent, False);
1800 Set_Current_Value (Elab_Ent, Empty);
1801 Set_Last_Assignment (Elab_Ent, Empty);
1802
1803 -- We do not want any further qualification of the name (if we did not
1804 -- do this, we would pick up the name of the generic package in the case
1805 -- of a library level generic instantiation).
1806
1807 Set_Has_Qualified_Name (Elab_Ent);
1808 Set_Has_Fully_Qualified_Name (Elab_Ent);
1809 end Build_Elaboration_Entity;
1810
1811 --------------------------------
1812 -- Build_Explicit_Dereference --
1813 --------------------------------
1814
1815 procedure Build_Explicit_Dereference
1816 (Expr : Node_Id;
1817 Disc : Entity_Id)
1818 is
1819 Loc : constant Source_Ptr := Sloc (Expr);
1820 I : Interp_Index;
1821 It : Interp;
1822
1823 begin
1824 -- An entity of a type with a reference aspect is overloaded with
1825 -- both interpretations: with and without the dereference. Now that
1826 -- the dereference is made explicit, set the type of the node properly,
1827 -- to prevent anomalies in the backend. Same if the expression is an
1828 -- overloaded function call whose return type has a reference aspect.
1829
1830 if Is_Entity_Name (Expr) then
1831 Set_Etype (Expr, Etype (Entity (Expr)));
1832
1833 -- The designated entity will not be examined again when resolving
1834 -- the dereference, so generate a reference to it now.
1835
1836 Generate_Reference (Entity (Expr), Expr);
1837
1838 elsif Nkind (Expr) = N_Function_Call then
1839
1840 -- If the name of the indexing function is overloaded, locate the one
1841 -- whose return type has an implicit dereference on the desired
1842 -- discriminant, and set entity and type of function call.
1843
1844 if Is_Overloaded (Name (Expr)) then
1845 Get_First_Interp (Name (Expr), I, It);
1846
1847 while Present (It.Nam) loop
1848 if Ekind ((It.Typ)) = E_Record_Type
1849 and then First_Entity ((It.Typ)) = Disc
1850 then
1851 Set_Entity (Name (Expr), It.Nam);
1852 Set_Etype (Name (Expr), Etype (It.Nam));
1853 exit;
1854 end if;
1855
1856 Get_Next_Interp (I, It);
1857 end loop;
1858 end if;
1859
1860 -- Set type of call from resolved function name.
1861
1862 Set_Etype (Expr, Etype (Name (Expr)));
1863 end if;
1864
1865 Set_Is_Overloaded (Expr, False);
1866
1867 -- The expression will often be a generalized indexing that yields a
1868 -- container element that is then dereferenced, in which case the
1869 -- generalized indexing call is also non-overloaded.
1870
1871 if Nkind (Expr) = N_Indexed_Component
1872 and then Present (Generalized_Indexing (Expr))
1873 then
1874 Set_Is_Overloaded (Generalized_Indexing (Expr), False);
1875 end if;
1876
1877 Rewrite (Expr,
1878 Make_Explicit_Dereference (Loc,
1879 Prefix =>
1880 Make_Selected_Component (Loc,
1881 Prefix => Relocate_Node (Expr),
1882 Selector_Name => New_Occurrence_Of (Disc, Loc))));
1883 Set_Etype (Prefix (Expr), Etype (Disc));
1884 Set_Etype (Expr, Designated_Type (Etype (Disc)));
1885 end Build_Explicit_Dereference;
1886
1887 -----------------------------------
1888 -- Cannot_Raise_Constraint_Error --
1889 -----------------------------------
1890
1891 function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
1892 begin
1893 if Compile_Time_Known_Value (Expr) then
1894 return True;
1895
1896 elsif Do_Range_Check (Expr) then
1897 return False;
1898
1899 elsif Raises_Constraint_Error (Expr) then
1900 return False;
1901
1902 else
1903 case Nkind (Expr) is
1904 when N_Identifier =>
1905 return True;
1906
1907 when N_Expanded_Name =>
1908 return True;
1909
1910 when N_Selected_Component =>
1911 return not Do_Discriminant_Check (Expr);
1912
1913 when N_Attribute_Reference =>
1914 if Do_Overflow_Check (Expr) then
1915 return False;
1916
1917 elsif No (Expressions (Expr)) then
1918 return True;
1919
1920 else
1921 declare
1922 N : Node_Id;
1923
1924 begin
1925 N := First (Expressions (Expr));
1926 while Present (N) loop
1927 if Cannot_Raise_Constraint_Error (N) then
1928 Next (N);
1929 else
1930 return False;
1931 end if;
1932 end loop;
1933
1934 return True;
1935 end;
1936 end if;
1937
1938 when N_Type_Conversion =>
1939 if Do_Overflow_Check (Expr)
1940 or else Do_Length_Check (Expr)
1941 or else Do_Tag_Check (Expr)
1942 then
1943 return False;
1944 else
1945 return Cannot_Raise_Constraint_Error (Expression (Expr));
1946 end if;
1947
1948 when N_Unchecked_Type_Conversion =>
1949 return Cannot_Raise_Constraint_Error (Expression (Expr));
1950
1951 when N_Unary_Op =>
1952 if Do_Overflow_Check (Expr) then
1953 return False;
1954 else
1955 return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1956 end if;
1957
1958 when N_Op_Divide |
1959 N_Op_Mod |
1960 N_Op_Rem
1961 =>
1962 if Do_Division_Check (Expr)
1963 or else
1964 Do_Overflow_Check (Expr)
1965 then
1966 return False;
1967 else
1968 return
1969 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1970 and then
1971 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1972 end if;
1973
1974 when N_Op_Add |
1975 N_Op_And |
1976 N_Op_Concat |
1977 N_Op_Eq |
1978 N_Op_Expon |
1979 N_Op_Ge |
1980 N_Op_Gt |
1981 N_Op_Le |
1982 N_Op_Lt |
1983 N_Op_Multiply |
1984 N_Op_Ne |
1985 N_Op_Or |
1986 N_Op_Rotate_Left |
1987 N_Op_Rotate_Right |
1988 N_Op_Shift_Left |
1989 N_Op_Shift_Right |
1990 N_Op_Shift_Right_Arithmetic |
1991 N_Op_Subtract |
1992 N_Op_Xor
1993 =>
1994 if Do_Overflow_Check (Expr) then
1995 return False;
1996 else
1997 return
1998 Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1999 and then
2000 Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
2001 end if;
2002
2003 when others =>
2004 return False;
2005 end case;
2006 end if;
2007 end Cannot_Raise_Constraint_Error;
2008
2009 -----------------------------
2010 -- Check_Part_Of_Reference --
2011 -----------------------------
2012
2013 procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is
2014 Conc_Typ : constant Entity_Id := Encapsulating_State (Var_Id);
2015 Decl : Node_Id;
2016 OK_Use : Boolean := False;
2017 Par : Node_Id;
2018 Prag_Nam : Name_Id;
2019 Spec_Id : Entity_Id;
2020
2021 begin
2022 -- Traverse the parent chain looking for a suitable context for the
2023 -- reference to the concurrent constituent.
2024
2025 Par := Parent (Ref);
2026 while Present (Par) loop
2027 if Nkind (Par) = N_Pragma then
2028 Prag_Nam := Pragma_Name (Par);
2029
2030 -- A concurrent constituent is allowed to appear in pragmas
2031 -- Initial_Condition and Initializes as this is part of the
2032 -- elaboration checks for the constituent (SPARK RM 9.3).
2033
2034 if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then
2035 OK_Use := True;
2036 exit;
2037
2038 -- When the reference appears within pragma Depends or Global,
2039 -- check whether the pragma applies to a single task type. Note
2040 -- that the pragma is not encapsulated by the type definition,
2041 -- but this is still a valid context.
2042
2043 elsif Nam_In (Prag_Nam, Name_Depends, Name_Global) then
2044 Decl := Find_Related_Declaration_Or_Body (Par);
2045
2046 if Nkind (Decl) = N_Object_Declaration
2047 and then Defining_Entity (Decl) = Conc_Typ
2048 then
2049 OK_Use := True;
2050 exit;
2051 end if;
2052 end if;
2053
2054 -- The reference appears somewhere in the definition of the single
2055 -- protected/task type (SPARK RM 9.3).
2056
2057 elsif Nkind_In (Par, N_Single_Protected_Declaration,
2058 N_Single_Task_Declaration)
2059 and then Defining_Entity (Par) = Conc_Typ
2060 then
2061 OK_Use := True;
2062 exit;
2063
2064 -- The reference appears within the expanded declaration or the body
2065 -- of the single protected/task type (SPARK RM 9.3).
2066
2067 elsif Nkind_In (Par, N_Protected_Body,
2068 N_Protected_Type_Declaration,
2069 N_Task_Body,
2070 N_Task_Type_Declaration)
2071 then
2072 Spec_Id := Unique_Defining_Entity (Par);
2073
2074 if Present (Anonymous_Object (Spec_Id))
2075 and then Anonymous_Object (Spec_Id) = Conc_Typ
2076 then
2077 OK_Use := True;
2078 exit;
2079 end if;
2080
2081 -- The reference has been relocated within an internally generated
2082 -- package or subprogram. Assume that the reference is legal as the
2083 -- real check was already performed in the original context of the
2084 -- reference.
2085
2086 elsif Nkind_In (Par, N_Package_Body,
2087 N_Package_Declaration,
2088 N_Subprogram_Body,
2089 N_Subprogram_Declaration)
2090 and then not Comes_From_Source (Par)
2091 then
2092 OK_Use := True;
2093 exit;
2094
2095 -- The reference has been relocated to an inlined body for GNATprove.
2096 -- Assume that the reference is legal as the real check was already
2097 -- performed in the original context of the reference.
2098
2099 elsif GNATprove_Mode
2100 and then Nkind (Par) = N_Subprogram_Body
2101 and then Chars (Defining_Entity (Par)) = Name_uParent
2102 then
2103 OK_Use := True;
2104 exit;
2105 end if;
2106
2107 Par := Parent (Par);
2108 end loop;
2109
2110 -- The reference is illegal as it appears outside the definition or
2111 -- body of the single protected/task type.
2112
2113 if not OK_Use then
2114 Error_Msg_NE
2115 ("reference to variable & cannot appear in this context",
2116 Ref, Var_Id);
2117 Error_Msg_Name_1 := Chars (Var_Id);
2118
2119 if Ekind (Conc_Typ) = E_Protected_Type then
2120 Error_Msg_NE
2121 ("\% is constituent of single protected type &", Ref, Conc_Typ);
2122 else
2123 Error_Msg_NE
2124 ("\% is constituent of single task type &", Ref, Conc_Typ);
2125 end if;
2126 end if;
2127 end Check_Part_Of_Reference;
2128
2129 -----------------------------------------
2130 -- Check_Dynamically_Tagged_Expression --
2131 -----------------------------------------
2132
2133 procedure Check_Dynamically_Tagged_Expression
2134 (Expr : Node_Id;
2135 Typ : Entity_Id;
2136 Related_Nod : Node_Id)
2137 is
2138 begin
2139 pragma Assert (Is_Tagged_Type (Typ));
2140
2141 -- In order to avoid spurious errors when analyzing the expanded code,
2142 -- this check is done only for nodes that come from source and for
2143 -- actuals of generic instantiations.
2144
2145 if (Comes_From_Source (Related_Nod)
2146 or else In_Generic_Actual (Expr))
2147 and then (Is_Class_Wide_Type (Etype (Expr))
2148 or else Is_Dynamically_Tagged (Expr))
2149 and then Is_Tagged_Type (Typ)
2150 and then not Is_Class_Wide_Type (Typ)
2151 then
2152 Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
2153 end if;
2154 end Check_Dynamically_Tagged_Expression;
2155
2156 --------------------------
2157 -- Check_Fully_Declared --
2158 --------------------------
2159
2160 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
2161 begin
2162 if Ekind (T) = E_Incomplete_Type then
2163
2164 -- Ada 2005 (AI-50217): If the type is available through a limited
2165 -- with_clause, verify that its full view has been analyzed.
2166
2167 if From_Limited_With (T)
2168 and then Present (Non_Limited_View (T))
2169 and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
2170 then
2171 -- The non-limited view is fully declared
2172
2173 null;
2174
2175 else
2176 Error_Msg_NE
2177 ("premature usage of incomplete}", N, First_Subtype (T));
2178 end if;
2179
2180 -- Need comments for these tests ???
2181
2182 elsif Has_Private_Component (T)
2183 and then not Is_Generic_Type (Root_Type (T))
2184 and then not In_Spec_Expression
2185 then
2186 -- Special case: if T is the anonymous type created for a single
2187 -- task or protected object, use the name of the source object.
2188
2189 if Is_Concurrent_Type (T)
2190 and then not Comes_From_Source (T)
2191 and then Nkind (N) = N_Object_Declaration
2192 then
2193 Error_Msg_NE
2194 ("type of& has incomplete component",
2195 N, Defining_Identifier (N));
2196 else
2197 Error_Msg_NE
2198 ("premature usage of incomplete}",
2199 N, First_Subtype (T));
2200 end if;
2201 end if;
2202 end Check_Fully_Declared;
2203
2204 -------------------------------------------
2205 -- Check_Function_With_Address_Parameter --
2206 -------------------------------------------
2207
2208 procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is
2209 F : Entity_Id;
2210 T : Entity_Id;
2211
2212 begin
2213 F := First_Formal (Subp_Id);
2214 while Present (F) loop
2215 T := Etype (F);
2216
2217 if Is_Private_Type (T) and then Present (Full_View (T)) then
2218 T := Full_View (T);
2219 end if;
2220
2221 if Is_Descendant_Of_Address (T) or else Is_Limited_Type (T) then
2222 Set_Is_Pure (Subp_Id, False);
2223 exit;
2224 end if;
2225
2226 Next_Formal (F);
2227 end loop;
2228 end Check_Function_With_Address_Parameter;
2229
2230 -------------------------------------
2231 -- Check_Function_Writable_Actuals --
2232 -------------------------------------
2233
2234 procedure Check_Function_Writable_Actuals (N : Node_Id) is
2235 Writable_Actuals_List : Elist_Id := No_Elist;
2236 Identifiers_List : Elist_Id := No_Elist;
2237 Aggr_Error_Node : Node_Id := Empty;
2238 Error_Node : Node_Id := Empty;
2239
2240 procedure Collect_Identifiers (N : Node_Id);
2241 -- In a single traversal of subtree N collect in Writable_Actuals_List
2242 -- all the actuals of functions with writable actuals, and in the list
2243 -- Identifiers_List collect all the identifiers that are not actuals of
2244 -- functions with writable actuals. If a writable actual is referenced
2245 -- twice as writable actual then Error_Node is set to reference its
2246 -- second occurrence, the error is reported, and the tree traversal
2247 -- is abandoned.
2248
2249 function Get_Function_Id (Call : Node_Id) return Entity_Id;
2250 -- Return the entity associated with the function call
2251
2252 procedure Preanalyze_Without_Errors (N : Node_Id);
2253 -- Preanalyze N without reporting errors. Very dubious, you can't just
2254 -- go analyzing things more than once???
2255
2256 -------------------------
2257 -- Collect_Identifiers --
2258 -------------------------
2259
2260 procedure Collect_Identifiers (N : Node_Id) is
2261
2262 function Check_Node (N : Node_Id) return Traverse_Result;
2263 -- Process a single node during the tree traversal to collect the
2264 -- writable actuals of functions and all the identifiers which are
2265 -- not writable actuals of functions.
2266
2267 function Contains (List : Elist_Id; N : Node_Id) return Boolean;
2268 -- Returns True if List has a node whose Entity is Entity (N)
2269
2270 -------------------------
2271 -- Check_Function_Call --
2272 -------------------------
2273
2274 function Check_Node (N : Node_Id) return Traverse_Result is
2275 Is_Writable_Actual : Boolean := False;
2276 Id : Entity_Id;
2277
2278 begin
2279 if Nkind (N) = N_Identifier then
2280
2281 -- No analysis possible if the entity is not decorated
2282
2283 if No (Entity (N)) then
2284 return Skip;
2285
2286 -- Don't collect identifiers of packages, called functions, etc
2287
2288 elsif Ekind_In (Entity (N), E_Package,
2289 E_Function,
2290 E_Procedure,
2291 E_Entry)
2292 then
2293 return Skip;
2294
2295 -- For rewritten nodes, continue the traversal in the original
2296 -- subtree. Needed to handle aggregates in original expressions
2297 -- extracted from the tree by Remove_Side_Effects.
2298
2299 elsif Is_Rewrite_Substitution (N) then
2300 Collect_Identifiers (Original_Node (N));
2301 return Skip;
2302
2303 -- For now we skip aggregate discriminants, since they require
2304 -- performing the analysis in two phases to identify conflicts:
2305 -- first one analyzing discriminants and second one analyzing
2306 -- the rest of components (since at run time, discriminants are
2307 -- evaluated prior to components): too much computation cost
2308 -- to identify a corner case???
2309
2310 elsif Nkind (Parent (N)) = N_Component_Association
2311 and then Nkind_In (Parent (Parent (N)),
2312 N_Aggregate,
2313 N_Extension_Aggregate)
2314 then
2315 declare
2316 Choice : constant Node_Id := First (Choices (Parent (N)));
2317
2318 begin
2319 if Ekind (Entity (N)) = E_Discriminant then
2320 return Skip;
2321
2322 elsif Expression (Parent (N)) = N
2323 and then Nkind (Choice) = N_Identifier
2324 and then Ekind (Entity (Choice)) = E_Discriminant
2325 then
2326 return Skip;
2327 end if;
2328 end;
2329
2330 -- Analyze if N is a writable actual of a function
2331
2332 elsif Nkind (Parent (N)) = N_Function_Call then
2333 declare
2334 Call : constant Node_Id := Parent (N);
2335 Actual : Node_Id;
2336 Formal : Node_Id;
2337
2338 begin
2339 Id := Get_Function_Id (Call);
2340
2341 -- In case of previous error, no check is possible
2342
2343 if No (Id) then
2344 return Abandon;
2345 end if;
2346
2347 if Ekind_In (Id, E_Function, E_Generic_Function)
2348 and then Has_Out_Or_In_Out_Parameter (Id)
2349 then
2350 Formal := First_Formal (Id);
2351 Actual := First_Actual (Call);
2352 while Present (Actual) and then Present (Formal) loop
2353 if Actual = N then
2354 if Ekind_In (Formal, E_Out_Parameter,
2355 E_In_Out_Parameter)
2356 then
2357 Is_Writable_Actual := True;
2358 end if;
2359
2360 exit;
2361 end if;
2362
2363 Next_Formal (Formal);
2364 Next_Actual (Actual);
2365 end loop;
2366 end if;
2367 end;
2368 end if;
2369
2370 if Is_Writable_Actual then
2371
2372 -- Skip checking the error in non-elementary types since
2373 -- RM 6.4.1(6.15/3) is restricted to elementary types, but
2374 -- store this actual in Writable_Actuals_List since it is
2375 -- needed to perform checks on other constructs that have
2376 -- arbitrary order of evaluation (for example, aggregates).
2377
2378 if not Is_Elementary_Type (Etype (N)) then
2379 if not Contains (Writable_Actuals_List, N) then
2380 Append_New_Elmt (N, To => Writable_Actuals_List);
2381 end if;
2382
2383 -- Second occurrence of an elementary type writable actual
2384
2385 elsif Contains (Writable_Actuals_List, N) then
2386
2387 -- Report the error on the second occurrence of the
2388 -- identifier. We cannot assume that N is the second
2389 -- occurrence (according to their location in the
2390 -- sources), since Traverse_Func walks through Field2
2391 -- last (see comment in the body of Traverse_Func).
2392
2393 declare
2394 Elmt : Elmt_Id;
2395
2396 begin
2397 Elmt := First_Elmt (Writable_Actuals_List);
2398 while Present (Elmt)
2399 and then Entity (Node (Elmt)) /= Entity (N)
2400 loop
2401 Next_Elmt (Elmt);
2402 end loop;
2403
2404 if Sloc (N) > Sloc (Node (Elmt)) then
2405 Error_Node := N;
2406 else
2407 Error_Node := Node (Elmt);
2408 end if;
2409
2410 Error_Msg_NE
2411 ("value may be affected by call to & "
2412 & "because order of evaluation is arbitrary",
2413 Error_Node, Id);
2414 return Abandon;
2415 end;
2416
2417 -- First occurrence of a elementary type writable actual
2418
2419 else
2420 Append_New_Elmt (N, To => Writable_Actuals_List);
2421 end if;
2422
2423 else
2424 if Identifiers_List = No_Elist then
2425 Identifiers_List := New_Elmt_List;
2426 end if;
2427
2428 Append_Unique_Elmt (N, Identifiers_List);
2429 end if;
2430 end if;
2431
2432 return OK;
2433 end Check_Node;
2434
2435 --------------
2436 -- Contains --
2437 --------------
2438
2439 function Contains
2440 (List : Elist_Id;
2441 N : Node_Id) return Boolean
2442 is
2443 pragma Assert (Nkind (N) in N_Has_Entity);
2444
2445 Elmt : Elmt_Id;
2446
2447 begin
2448 if List = No_Elist then
2449 return False;
2450 end if;
2451
2452 Elmt := First_Elmt (List);
2453 while Present (Elmt) loop
2454 if Entity (Node (Elmt)) = Entity (N) then
2455 return True;
2456 else
2457 Next_Elmt (Elmt);
2458 end if;
2459 end loop;
2460
2461 return False;
2462 end Contains;
2463
2464 ------------------
2465 -- Do_Traversal --
2466 ------------------
2467
2468 procedure Do_Traversal is new Traverse_Proc (Check_Node);
2469 -- The traversal procedure
2470
2471 -- Start of processing for Collect_Identifiers
2472
2473 begin
2474 if Present (Error_Node) then
2475 return;
2476 end if;
2477
2478 if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then
2479 return;
2480 end if;
2481
2482 Do_Traversal (N);
2483 end Collect_Identifiers;
2484
2485 ---------------------
2486 -- Get_Function_Id --
2487 ---------------------
2488
2489 function Get_Function_Id (Call : Node_Id) return Entity_Id is
2490 Nam : constant Node_Id := Name (Call);
2491 Id : Entity_Id;
2492
2493 begin
2494 if Nkind (Nam) = N_Explicit_Dereference then
2495 Id := Etype (Nam);
2496 pragma Assert (Ekind (Id) = E_Subprogram_Type);
2497
2498 elsif Nkind (Nam) = N_Selected_Component then
2499 Id := Entity (Selector_Name (Nam));
2500
2501 elsif Nkind (Nam) = N_Indexed_Component then
2502 Id := Entity (Selector_Name (Prefix (Nam)));
2503
2504 else
2505 Id := Entity (Nam);
2506 end if;
2507
2508 return Id;
2509 end Get_Function_Id;
2510
2511 -------------------------------
2512 -- Preanalyze_Without_Errors --
2513 -------------------------------
2514
2515 procedure Preanalyze_Without_Errors (N : Node_Id) is
2516 Status : constant Boolean := Get_Ignore_Errors;
2517 begin
2518 Set_Ignore_Errors (True);
2519 Preanalyze (N);
2520 Set_Ignore_Errors (Status);
2521 end Preanalyze_Without_Errors;
2522
2523 -- Start of processing for Check_Function_Writable_Actuals
2524
2525 begin
2526 -- The check only applies to Ada 2012 code on which Check_Actuals has
2527 -- been set, and only to constructs that have multiple constituents
2528 -- whose order of evaluation is not specified by the language.
2529
2530 if Ada_Version < Ada_2012
2531 or else not Check_Actuals (N)
2532 or else (not (Nkind (N) in N_Op)
2533 and then not (Nkind (N) in N_Membership_Test)
2534 and then not Nkind_In (N, N_Range,
2535 N_Aggregate,
2536 N_Extension_Aggregate,
2537 N_Full_Type_Declaration,
2538 N_Function_Call,
2539 N_Procedure_Call_Statement,
2540 N_Entry_Call_Statement))
2541 or else (Nkind (N) = N_Full_Type_Declaration
2542 and then not Is_Record_Type (Defining_Identifier (N)))
2543
2544 -- In addition, this check only applies to source code, not to code
2545 -- generated by constraint checks.
2546
2547 or else not Comes_From_Source (N)
2548 then
2549 return;
2550 end if;
2551
2552 -- If a construct C has two or more direct constituents that are names
2553 -- or expressions whose evaluation may occur in an arbitrary order, at
2554 -- least one of which contains a function call with an in out or out
2555 -- parameter, then the construct is legal only if: for each name N that
2556 -- is passed as a parameter of mode in out or out to some inner function
2557 -- call C2 (not including the construct C itself), there is no other
2558 -- name anywhere within a direct constituent of the construct C other
2559 -- than the one containing C2, that is known to refer to the same
2560 -- object (RM 6.4.1(6.17/3)).
2561
2562 case Nkind (N) is
2563 when N_Range =>
2564 Collect_Identifiers (Low_Bound (N));
2565 Collect_Identifiers (High_Bound (N));
2566
2567 when N_Op | N_Membership_Test =>
2568 declare
2569 Expr : Node_Id;
2570
2571 begin
2572 Collect_Identifiers (Left_Opnd (N));
2573
2574 if Present (Right_Opnd (N)) then
2575 Collect_Identifiers (Right_Opnd (N));
2576 end if;
2577
2578 if Nkind_In (N, N_In, N_Not_In)
2579 and then Present (Alternatives (N))
2580 then
2581 Expr := First (Alternatives (N));
2582 while Present (Expr) loop
2583 Collect_Identifiers (Expr);
2584
2585 Next (Expr);
2586 end loop;
2587 end if;
2588 end;
2589
2590 when N_Full_Type_Declaration =>
2591 declare
2592 function Get_Record_Part (N : Node_Id) return Node_Id;
2593 -- Return the record part of this record type definition
2594
2595 function Get_Record_Part (N : Node_Id) return Node_Id is
2596 Type_Def : constant Node_Id := Type_Definition (N);
2597 begin
2598 if Nkind (Type_Def) = N_Derived_Type_Definition then
2599 return Record_Extension_Part (Type_Def);
2600 else
2601 return Type_Def;
2602 end if;
2603 end Get_Record_Part;
2604
2605 Comp : Node_Id;
2606 Def_Id : Entity_Id := Defining_Identifier (N);
2607 Rec : Node_Id := Get_Record_Part (N);
2608
2609 begin
2610 -- No need to perform any analysis if the record has no
2611 -- components
2612
2613 if No (Rec) or else No (Component_List (Rec)) then
2614 return;
2615 end if;
2616
2617 -- Collect the identifiers starting from the deepest
2618 -- derivation. Done to report the error in the deepest
2619 -- derivation.
2620
2621 loop
2622 if Present (Component_List (Rec)) then
2623 Comp := First (Component_Items (Component_List (Rec)));
2624 while Present (Comp) loop
2625 if Nkind (Comp) = N_Component_Declaration
2626 and then Present (Expression (Comp))
2627 then
2628 Collect_Identifiers (Expression (Comp));
2629 end if;
2630
2631 Next (Comp);
2632 end loop;
2633 end if;
2634
2635 exit when No (Underlying_Type (Etype (Def_Id)))
2636 or else Base_Type (Underlying_Type (Etype (Def_Id)))
2637 = Def_Id;
2638
2639 Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
2640 Rec := Get_Record_Part (Parent (Def_Id));
2641 end loop;
2642 end;
2643
2644 when N_Subprogram_Call |
2645 N_Entry_Call_Statement =>
2646 declare
2647 Id : constant Entity_Id := Get_Function_Id (N);
2648 Formal : Node_Id;
2649 Actual : Node_Id;
2650
2651 begin
2652 Formal := First_Formal (Id);
2653 Actual := First_Actual (N);
2654 while Present (Actual) and then Present (Formal) loop
2655 if Ekind_In (Formal, E_Out_Parameter,
2656 E_In_Out_Parameter)
2657 then
2658 Collect_Identifiers (Actual);
2659 end if;
2660
2661 Next_Formal (Formal);
2662 Next_Actual (Actual);
2663 end loop;
2664 end;
2665
2666 when N_Aggregate |
2667 N_Extension_Aggregate =>
2668 declare
2669 Assoc : Node_Id;
2670 Choice : Node_Id;
2671 Comp_Expr : Node_Id;
2672
2673 begin
2674 -- Handle the N_Others_Choice of array aggregates with static
2675 -- bounds. There is no need to perform this analysis in
2676 -- aggregates without static bounds since we cannot evaluate
2677 -- if the N_Others_Choice covers several elements. There is
2678 -- no need to handle the N_Others choice of record aggregates
2679 -- since at this stage it has been already expanded by
2680 -- Resolve_Record_Aggregate.
2681
2682 if Is_Array_Type (Etype (N))
2683 and then Nkind (N) = N_Aggregate
2684 and then Present (Aggregate_Bounds (N))
2685 and then Compile_Time_Known_Bounds (Etype (N))
2686 and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
2687 >
2688 Expr_Value (Low_Bound (Aggregate_Bounds (N)))
2689 then
2690 declare
2691 Count_Components : Uint := Uint_0;
2692 Num_Components : Uint;
2693 Others_Assoc : Node_Id;
2694 Others_Choice : Node_Id := Empty;
2695 Others_Box_Present : Boolean := False;
2696
2697 begin
2698 -- Count positional associations
2699
2700 if Present (Expressions (N)) then
2701 Comp_Expr := First (Expressions (N));
2702 while Present (Comp_Expr) loop
2703 Count_Components := Count_Components + 1;
2704 Next (Comp_Expr);
2705 end loop;
2706 end if;
2707
2708 -- Count the rest of elements and locate the N_Others
2709 -- choice (if any)
2710
2711 Assoc := First (Component_Associations (N));
2712 while Present (Assoc) loop
2713 Choice := First (Choices (Assoc));
2714 while Present (Choice) loop
2715 if Nkind (Choice) = N_Others_Choice then
2716 Others_Assoc := Assoc;
2717 Others_Choice := Choice;
2718 Others_Box_Present := Box_Present (Assoc);
2719
2720 -- Count several components
2721
2722 elsif Nkind_In (Choice, N_Range,
2723 N_Subtype_Indication)
2724 or else (Is_Entity_Name (Choice)
2725 and then Is_Type (Entity (Choice)))
2726 then
2727 declare
2728 L, H : Node_Id;
2729 begin
2730 Get_Index_Bounds (Choice, L, H);
2731 pragma Assert
2732 (Compile_Time_Known_Value (L)
2733 and then Compile_Time_Known_Value (H));
2734 Count_Components :=
2735 Count_Components
2736 + Expr_Value (H) - Expr_Value (L) + 1;
2737 end;
2738
2739 -- Count single component. No other case available
2740 -- since we are handling an aggregate with static
2741 -- bounds.
2742
2743 else
2744 pragma Assert (Is_OK_Static_Expression (Choice)
2745 or else Nkind (Choice) = N_Identifier
2746 or else Nkind (Choice) = N_Integer_Literal);
2747
2748 Count_Components := Count_Components + 1;
2749 end if;
2750
2751 Next (Choice);
2752 end loop;
2753
2754 Next (Assoc);
2755 end loop;
2756
2757 Num_Components :=
2758 Expr_Value (High_Bound (Aggregate_Bounds (N))) -
2759 Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
2760
2761 pragma Assert (Count_Components <= Num_Components);
2762
2763 -- Handle the N_Others choice if it covers several
2764 -- components
2765
2766 if Present (Others_Choice)
2767 and then (Num_Components - Count_Components) > 1
2768 then
2769 if not Others_Box_Present then
2770
2771 -- At this stage, if expansion is active, the
2772 -- expression of the others choice has not been
2773 -- analyzed. Hence we generate a duplicate and
2774 -- we analyze it silently to have available the
2775 -- minimum decoration required to collect the
2776 -- identifiers.
2777
2778 if not Expander_Active then
2779 Comp_Expr := Expression (Others_Assoc);
2780 else
2781 Comp_Expr :=
2782 New_Copy_Tree (Expression (Others_Assoc));
2783 Preanalyze_Without_Errors (Comp_Expr);
2784 end if;
2785
2786 Collect_Identifiers (Comp_Expr);
2787
2788 if Writable_Actuals_List /= No_Elist then
2789
2790 -- As suggested by Robert, at current stage we
2791 -- report occurrences of this case as warnings.
2792
2793 Error_Msg_N
2794 ("writable function parameter may affect "
2795 & "value in other component because order "
2796 & "of evaluation is unspecified??",
2797 Node (First_Elmt (Writable_Actuals_List)));
2798 end if;
2799 end if;
2800 end if;
2801 end;
2802
2803 -- For an array aggregate, a discrete_choice_list that has
2804 -- a nonstatic range is considered as two or more separate
2805 -- occurrences of the expression (RM 6.4.1(20/3)).
2806
2807 elsif Is_Array_Type (Etype (N))
2808 and then Nkind (N) = N_Aggregate
2809 and then Present (Aggregate_Bounds (N))
2810 and then not Compile_Time_Known_Bounds (Etype (N))
2811 then
2812 -- Collect identifiers found in the dynamic bounds
2813
2814 declare
2815 Count_Components : Natural := 0;
2816 Low, High : Node_Id;
2817
2818 begin
2819 Assoc := First (Component_Associations (N));
2820 while Present (Assoc) loop
2821 Choice := First (Choices (Assoc));
2822 while Present (Choice) loop
2823 if Nkind_In (Choice, N_Range,
2824 N_Subtype_Indication)
2825 or else (Is_Entity_Name (Choice)
2826 and then Is_Type (Entity (Choice)))
2827 then
2828 Get_Index_Bounds (Choice, Low, High);
2829
2830 if not Compile_Time_Known_Value (Low) then
2831 Collect_Identifiers (Low);
2832
2833 if No (Aggr_Error_Node) then
2834 Aggr_Error_Node := Low;
2835 end if;
2836 end if;
2837
2838 if not Compile_Time_Known_Value (High) then
2839 Collect_Identifiers (High);
2840
2841 if No (Aggr_Error_Node) then
2842 Aggr_Error_Node := High;
2843 end if;
2844 end if;
2845
2846 -- The RM rule is violated if there is more than
2847 -- a single choice in a component association.
2848
2849 else
2850 Count_Components := Count_Components + 1;
2851
2852 if No (Aggr_Error_Node)
2853 and then Count_Components > 1
2854 then
2855 Aggr_Error_Node := Choice;
2856 end if;
2857
2858 if not Compile_Time_Known_Value (Choice) then
2859 Collect_Identifiers (Choice);
2860 end if;
2861 end if;
2862
2863 Next (Choice);
2864 end loop;
2865
2866 Next (Assoc);
2867 end loop;
2868 end;
2869 end if;
2870
2871 -- Handle ancestor part of extension aggregates
2872
2873 if Nkind (N) = N_Extension_Aggregate then
2874 Collect_Identifiers (Ancestor_Part (N));
2875 end if;
2876
2877 -- Handle positional associations
2878
2879 if Present (Expressions (N)) then
2880 Comp_Expr := First (Expressions (N));
2881 while Present (Comp_Expr) loop
2882 if not Is_OK_Static_Expression (Comp_Expr) then
2883 Collect_Identifiers (Comp_Expr);
2884 end if;
2885
2886 Next (Comp_Expr);
2887 end loop;
2888 end if;
2889
2890 -- Handle discrete associations
2891
2892 if Present (Component_Associations (N)) then
2893 Assoc := First (Component_Associations (N));
2894 while Present (Assoc) loop
2895
2896 if not Box_Present (Assoc) then
2897 Choice := First (Choices (Assoc));
2898 while Present (Choice) loop
2899
2900 -- For now we skip discriminants since it requires
2901 -- performing the analysis in two phases: first one
2902 -- analyzing discriminants and second one analyzing
2903 -- the rest of components since discriminants are
2904 -- evaluated prior to components: too much extra
2905 -- work to detect a corner case???
2906
2907 if Nkind (Choice) in N_Has_Entity
2908 and then Present (Entity (Choice))
2909 and then Ekind (Entity (Choice)) = E_Discriminant
2910 then
2911 null;
2912
2913 elsif Box_Present (Assoc) then
2914 null;
2915
2916 else
2917 if not Analyzed (Expression (Assoc)) then
2918 Comp_Expr :=
2919 New_Copy_Tree (Expression (Assoc));
2920 Set_Parent (Comp_Expr, Parent (N));
2921 Preanalyze_Without_Errors (Comp_Expr);
2922 else
2923 Comp_Expr := Expression (Assoc);
2924 end if;
2925
2926 Collect_Identifiers (Comp_Expr);
2927 end if;
2928
2929 Next (Choice);
2930 end loop;
2931 end if;
2932
2933 Next (Assoc);
2934 end loop;
2935 end if;
2936 end;
2937
2938 when others =>
2939 return;
2940 end case;
2941
2942 -- No further action needed if we already reported an error
2943
2944 if Present (Error_Node) then
2945 return;
2946 end if;
2947
2948 -- Check violation of RM 6.20/3 in aggregates
2949
2950 if Present (Aggr_Error_Node)
2951 and then Writable_Actuals_List /= No_Elist
2952 then
2953 Error_Msg_N
2954 ("value may be affected by call in other component because they "
2955 & "are evaluated in unspecified order",
2956 Node (First_Elmt (Writable_Actuals_List)));
2957 return;
2958 end if;
2959
2960 -- Check if some writable argument of a function is referenced
2961
2962 if Writable_Actuals_List /= No_Elist
2963 and then Identifiers_List /= No_Elist
2964 then
2965 declare
2966 Elmt_1 : Elmt_Id;
2967 Elmt_2 : Elmt_Id;
2968
2969 begin
2970 Elmt_1 := First_Elmt (Writable_Actuals_List);
2971 while Present (Elmt_1) loop
2972 Elmt_2 := First_Elmt (Identifiers_List);
2973 while Present (Elmt_2) loop
2974 if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
2975 case Nkind (Parent (Node (Elmt_2))) is
2976 when N_Aggregate |
2977 N_Component_Association |
2978 N_Component_Declaration =>
2979 Error_Msg_N
2980 ("value may be affected by call in other "
2981 & "component because they are evaluated "
2982 & "in unspecified order",
2983 Node (Elmt_2));
2984
2985 when N_In | N_Not_In =>
2986 Error_Msg_N
2987 ("value may be affected by call in other "
2988 & "alternative because they are evaluated "
2989 & "in unspecified order",
2990 Node (Elmt_2));
2991
2992 when others =>
2993 Error_Msg_N
2994 ("value of actual may be affected by call in "
2995 & "other actual because they are evaluated "
2996 & "in unspecified order",
2997 Node (Elmt_2));
2998 end case;
2999 end if;
3000
3001 Next_Elmt (Elmt_2);
3002 end loop;
3003
3004 Next_Elmt (Elmt_1);
3005 end loop;
3006 end;
3007 end if;
3008 end Check_Function_Writable_Actuals;
3009
3010 --------------------------------
3011 -- Check_Implicit_Dereference --
3012 --------------------------------
3013
3014 procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is
3015 Disc : Entity_Id;
3016 Desig : Entity_Id;
3017 Nam : Node_Id;
3018
3019 begin
3020 if Nkind (N) = N_Indexed_Component
3021 and then Present (Generalized_Indexing (N))
3022 then
3023 Nam := Generalized_Indexing (N);
3024 else
3025 Nam := N;
3026 end if;
3027
3028 if Ada_Version < Ada_2012
3029 or else not Has_Implicit_Dereference (Base_Type (Typ))
3030 then
3031 return;
3032
3033 elsif not Comes_From_Source (N)
3034 and then Nkind (N) /= N_Indexed_Component
3035 then
3036 return;
3037
3038 elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then
3039 null;
3040
3041 else
3042 Disc := First_Discriminant (Typ);
3043 while Present (Disc) loop
3044 if Has_Implicit_Dereference (Disc) then
3045 Desig := Designated_Type (Etype (Disc));
3046 Add_One_Interp (Nam, Disc, Desig);
3047
3048 -- If the node is a generalized indexing, add interpretation
3049 -- to that node as well, for subsequent resolution.
3050
3051 if Nkind (N) = N_Indexed_Component then
3052 Add_One_Interp (N, Disc, Desig);
3053 end if;
3054
3055 -- If the operation comes from a generic unit and the context
3056 -- is a selected component, the selector name may be global
3057 -- and set in the instance already. Remove the entity to
3058 -- force resolution of the selected component, and the
3059 -- generation of an explicit dereference if needed.
3060
3061 if In_Instance
3062 and then Nkind (Parent (Nam)) = N_Selected_Component
3063 then
3064 Set_Entity (Selector_Name (Parent (Nam)), Empty);
3065 end if;
3066
3067 exit;
3068 end if;
3069
3070 Next_Discriminant (Disc);
3071 end loop;
3072 end if;
3073 end Check_Implicit_Dereference;
3074
3075 ----------------------------------
3076 -- Check_Internal_Protected_Use --
3077 ----------------------------------
3078
3079 procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
3080 S : Entity_Id;
3081 Prot : Entity_Id;
3082
3083 begin
3084 S := Current_Scope;
3085 while Present (S) loop
3086 if S = Standard_Standard then
3087 return;
3088
3089 elsif Ekind (S) = E_Function
3090 and then Ekind (Scope (S)) = E_Protected_Type
3091 then
3092 Prot := Scope (S);
3093 exit;
3094 end if;
3095
3096 S := Scope (S);
3097 end loop;
3098
3099 if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then
3100
3101 -- An indirect function call (e.g. a callback within a protected
3102 -- function body) is not statically illegal. If the access type is
3103 -- anonymous and is the type of an access parameter, the scope of Nam
3104 -- will be the protected type, but it is not a protected operation.
3105
3106 if Ekind (Nam) = E_Subprogram_Type
3107 and then
3108 Nkind (Associated_Node_For_Itype (Nam)) = N_Function_Specification
3109 then
3110 null;
3111
3112 elsif Nkind (N) = N_Subprogram_Renaming_Declaration then
3113 Error_Msg_N
3114 ("within protected function cannot use protected "
3115 & "procedure in renaming or as generic actual", N);
3116
3117 elsif Nkind (N) = N_Attribute_Reference then
3118 Error_Msg_N
3119 ("within protected function cannot take access of "
3120 & " protected procedure", N);
3121
3122 else
3123 Error_Msg_N
3124 ("within protected function, protected object is constant", N);
3125 Error_Msg_N
3126 ("\cannot call operation that may modify it", N);
3127 end if;
3128 end if;
3129 end Check_Internal_Protected_Use;
3130
3131 ---------------------------------------
3132 -- Check_Later_Vs_Basic_Declarations --
3133 ---------------------------------------
3134
3135 procedure Check_Later_Vs_Basic_Declarations
3136 (Decls : List_Id;
3137 During_Parsing : Boolean)
3138 is
3139 Body_Sloc : Source_Ptr;
3140 Decl : Node_Id;
3141
3142 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
3143 -- Return whether Decl is considered as a declarative item.
3144 -- When During_Parsing is True, the semantics of Ada 83 is followed.
3145 -- When During_Parsing is False, the semantics of SPARK is followed.
3146
3147 -------------------------------
3148 -- Is_Later_Declarative_Item --
3149 -------------------------------
3150
3151 function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
3152 begin
3153 if Nkind (Decl) in N_Later_Decl_Item then
3154 return True;
3155
3156 elsif Nkind (Decl) = N_Pragma then
3157 return True;
3158
3159 elsif During_Parsing then
3160 return False;
3161
3162 -- In SPARK, a package declaration is not considered as a later
3163 -- declarative item.
3164
3165 elsif Nkind (Decl) = N_Package_Declaration then
3166 return False;
3167
3168 -- In SPARK, a renaming is considered as a later declarative item
3169
3170 elsif Nkind (Decl) in N_Renaming_Declaration then
3171 return True;
3172
3173 else
3174 return False;
3175 end if;
3176 end Is_Later_Declarative_Item;
3177
3178 -- Start of processing for Check_Later_Vs_Basic_Declarations
3179
3180 begin
3181 Decl := First (Decls);
3182
3183 -- Loop through sequence of basic declarative items
3184
3185 Outer : while Present (Decl) loop
3186 if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
3187 and then Nkind (Decl) not in N_Body_Stub
3188 then
3189 Next (Decl);
3190
3191 -- Once a body is encountered, we only allow later declarative
3192 -- items. The inner loop checks the rest of the list.
3193
3194 else
3195 Body_Sloc := Sloc (Decl);
3196
3197 Inner : while Present (Decl) loop
3198 if not Is_Later_Declarative_Item (Decl) then
3199 if During_Parsing then
3200 if Ada_Version = Ada_83 then
3201 Error_Msg_Sloc := Body_Sloc;
3202 Error_Msg_N
3203 ("(Ada 83) decl cannot appear after body#", Decl);
3204 end if;
3205 else
3206 Error_Msg_Sloc := Body_Sloc;
3207 Check_SPARK_05_Restriction
3208 ("decl cannot appear after body#", Decl);
3209 end if;
3210 end if;
3211
3212 Next (Decl);
3213 end loop Inner;
3214 end if;
3215 end loop Outer;
3216 end Check_Later_Vs_Basic_Declarations;
3217
3218 ---------------------------
3219 -- Check_No_Hidden_State --
3220 ---------------------------
3221
3222 procedure Check_No_Hidden_State (Id : Entity_Id) is
3223 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean;
3224 -- Determine whether the entity of a package denoted by Pkg has a null
3225 -- abstract state.
3226
3227 -----------------------------
3228 -- Has_Null_Abstract_State --
3229 -----------------------------
3230
3231 function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is
3232 States : constant Elist_Id := Abstract_States (Pkg);
3233
3234 begin
3235 -- Check first available state of related package. A null abstract
3236 -- state always appears as the sole element of the state list.
3237
3238 return
3239 Present (States)
3240 and then Is_Null_State (Node (First_Elmt (States)));
3241 end Has_Null_Abstract_State;
3242
3243 -- Local variables
3244
3245 Context : Entity_Id := Empty;
3246 Not_Visible : Boolean := False;
3247 Scop : Entity_Id;
3248
3249 -- Start of processing for Check_No_Hidden_State
3250
3251 begin
3252 pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
3253
3254 -- Find the proper context where the object or state appears
3255
3256 Scop := Scope (Id);
3257 while Present (Scop) loop
3258 Context := Scop;
3259
3260 -- Keep track of the context's visibility
3261
3262 Not_Visible := Not_Visible or else In_Private_Part (Context);
3263
3264 -- Prevent the search from going too far
3265
3266 if Context = Standard_Standard then
3267 return;
3268
3269 -- Objects and states that appear immediately within a subprogram or
3270 -- inside a construct nested within a subprogram do not introduce a
3271 -- hidden state. They behave as local variable declarations.
3272
3273 elsif Is_Subprogram (Context) then
3274 return;
3275
3276 -- When examining a package body, use the entity of the spec as it
3277 -- carries the abstract state declarations.
3278
3279 elsif Ekind (Context) = E_Package_Body then
3280 Context := Spec_Entity (Context);
3281 end if;
3282
3283 -- Stop the traversal when a package subject to a null abstract state
3284 -- has been found.
3285
3286 if Ekind_In (Context, E_Generic_Package, E_Package)
3287 and then Has_Null_Abstract_State (Context)
3288 then
3289 exit;
3290 end if;
3291
3292 Scop := Scope (Scop);
3293 end loop;
3294
3295 -- At this point we know that there is at least one package with a null
3296 -- abstract state in visibility. Emit an error message unconditionally
3297 -- if the entity being processed is a state because the placement of the
3298 -- related package is irrelevant. This is not the case for objects as
3299 -- the intermediate context matters.
3300
3301 if Present (Context)
3302 and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
3303 then
3304 Error_Msg_N ("cannot introduce hidden state &", Id);
3305 Error_Msg_NE ("\package & has null abstract state", Id, Context);
3306 end if;
3307 end Check_No_Hidden_State;
3308
3309 ----------------------------------------
3310 -- Check_Nonvolatile_Function_Profile --
3311 ----------------------------------------
3312
3313 procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id) is
3314 Formal : Entity_Id;
3315
3316 begin
3317 -- Inspect all formal parameters
3318
3319 Formal := First_Formal (Func_Id);
3320 while Present (Formal) loop
3321 if Is_Effectively_Volatile (Etype (Formal)) then
3322 Error_Msg_NE
3323 ("nonvolatile function & cannot have a volatile parameter",
3324 Formal, Func_Id);
3325 end if;
3326
3327 Next_Formal (Formal);
3328 end loop;
3329
3330 -- Inspect the return type
3331
3332 if Is_Effectively_Volatile (Etype (Func_Id)) then
3333 Error_Msg_NE
3334 ("nonvolatile function & cannot have a volatile return type",
3335 Result_Definition (Parent (Func_Id)), Func_Id);
3336 end if;
3337 end Check_Nonvolatile_Function_Profile;
3338
3339 ------------------------------------------
3340 -- Check_Potentially_Blocking_Operation --
3341 ------------------------------------------
3342
3343 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
3344 S : Entity_Id;
3345
3346 begin
3347 -- N is one of the potentially blocking operations listed in 9.5.1(8).
3348 -- When pragma Detect_Blocking is active, the run time will raise
3349 -- Program_Error. Here we only issue a warning, since we generally
3350 -- support the use of potentially blocking operations in the absence
3351 -- of the pragma.
3352
3353 -- Indirect blocking through a subprogram call cannot be diagnosed
3354 -- statically without interprocedural analysis, so we do not attempt
3355 -- to do it here.
3356
3357 S := Scope (Current_Scope);
3358 while Present (S) and then S /= Standard_Standard loop
3359 if Is_Protected_Type (S) then
3360 Error_Msg_N
3361 ("potentially blocking operation in protected operation??", N);
3362 return;
3363 end if;
3364
3365 S := Scope (S);
3366 end loop;
3367 end Check_Potentially_Blocking_Operation;
3368
3369 ---------------------------------
3370 -- Check_Result_And_Post_State --
3371 ---------------------------------
3372
3373 procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is
3374 procedure Check_Result_And_Post_State_In_Pragma
3375 (Prag : Node_Id;
3376 Result_Seen : in out Boolean);
3377 -- Determine whether pragma Prag mentions attribute 'Result and whether
3378 -- the pragma contains an expression that evaluates differently in pre-
3379 -- and post-state. Prag is a [refined] postcondition or a contract-cases
3380 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result
3381
3382 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean;
3383 -- Determine whether subprogram Subp_Id contains at least one IN OUT
3384 -- formal parameter.
3385
3386 -------------------------------------------
3387 -- Check_Result_And_Post_State_In_Pragma --
3388 -------------------------------------------
3389
3390 procedure Check_Result_And_Post_State_In_Pragma
3391 (Prag : Node_Id;
3392 Result_Seen : in out Boolean)
3393 is
3394 procedure Check_Expression (Expr : Node_Id);
3395 -- Perform the 'Result and post-state checks on a given expression
3396
3397 function Is_Function_Result (N : Node_Id) return Traverse_Result;
3398 -- Attempt to find attribute 'Result in a subtree denoted by N
3399
3400 function Is_Trivial_Boolean (N : Node_Id) return Boolean;
3401 -- Determine whether source node N denotes "True" or "False"
3402
3403 function Mentions_Post_State (N : Node_Id) return Boolean;
3404 -- Determine whether a subtree denoted by N mentions any construct
3405 -- that denotes a post-state.
3406
3407 procedure Check_Function_Result is
3408 new Traverse_Proc (Is_Function_Result);
3409
3410 ----------------------
3411 -- Check_Expression --
3412 ----------------------
3413
3414 procedure Check_Expression (Expr : Node_Id) is
3415 begin
3416 if not Is_Trivial_Boolean (Expr) then
3417 Check_Function_Result (Expr);
3418
3419 if not Mentions_Post_State (Expr) then
3420 if Pragma_Name (Prag) = Name_Contract_Cases then
3421 Error_Msg_NE
3422 ("contract case does not check the outcome of calling "
3423 & "&?T?", Expr, Subp_Id);
3424
3425 elsif Pragma_Name (Prag) = Name_Refined_Post then
3426 Error_Msg_NE
3427 ("refined postcondition does not check the outcome of "
3428 & "calling &?T?", Prag, Subp_Id);
3429
3430 else
3431 Error_Msg_NE
3432 ("postcondition does not check the outcome of calling "
3433 & "&?T?", Prag, Subp_Id);
3434 end if;
3435 end if;
3436 end if;
3437 end Check_Expression;
3438
3439 ------------------------
3440 -- Is_Function_Result --
3441 ------------------------
3442
3443 function Is_Function_Result (N : Node_Id) return Traverse_Result is
3444 begin
3445 if Is_Attribute_Result (N) then
3446 Result_Seen := True;
3447 return Abandon;
3448
3449 -- Continue the traversal
3450
3451 else
3452 return OK;
3453 end if;
3454 end Is_Function_Result;
3455
3456 ------------------------
3457 -- Is_Trivial_Boolean --
3458 ------------------------
3459
3460 function Is_Trivial_Boolean (N : Node_Id) return Boolean is
3461 begin
3462 return
3463 Comes_From_Source (N)
3464 and then Is_Entity_Name (N)
3465 and then (Entity (N) = Standard_True
3466 or else
3467 Entity (N) = Standard_False);
3468 end Is_Trivial_Boolean;
3469
3470 -------------------------
3471 -- Mentions_Post_State --
3472 -------------------------
3473
3474 function Mentions_Post_State (N : Node_Id) return Boolean is
3475 Post_State_Seen : Boolean := False;
3476
3477 function Is_Post_State (N : Node_Id) return Traverse_Result;
3478 -- Attempt to find a construct that denotes a post-state. If this
3479 -- is the case, set flag Post_State_Seen.
3480
3481 -------------------
3482 -- Is_Post_State --
3483 -------------------
3484
3485 function Is_Post_State (N : Node_Id) return Traverse_Result is
3486 Ent : Entity_Id;
3487
3488 begin
3489 if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then
3490 Post_State_Seen := True;
3491 return Abandon;
3492
3493 elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then
3494 Ent := Entity (N);
3495
3496 -- The entity may be modifiable through an implicit
3497 -- dereference.
3498
3499 if No (Ent)
3500 or else Ekind (Ent) in Assignable_Kind
3501 or else (Is_Access_Type (Etype (Ent))
3502 and then Nkind (Parent (N)) =
3503 N_Selected_Component)
3504 then
3505 Post_State_Seen := True;
3506 return Abandon;
3507 end if;
3508
3509 elsif Nkind (N) = N_Attribute_Reference then
3510 if Attribute_Name (N) = Name_Old then
3511 return Skip;
3512
3513 elsif Attribute_Name (N) = Name_Result then
3514 Post_State_Seen := True;
3515 return Abandon;
3516 end if;
3517 end if;
3518
3519 return OK;
3520 end Is_Post_State;
3521
3522 procedure Find_Post_State is new Traverse_Proc (Is_Post_State);
3523
3524 -- Start of processing for Mentions_Post_State
3525
3526 begin
3527 Find_Post_State (N);
3528
3529 return Post_State_Seen;
3530 end Mentions_Post_State;
3531
3532 -- Local variables
3533
3534 Expr : constant Node_Id :=
3535 Get_Pragma_Arg
3536 (First (Pragma_Argument_Associations (Prag)));
3537 Nam : constant Name_Id := Pragma_Name (Prag);
3538 CCase : Node_Id;
3539
3540 -- Start of processing for Check_Result_And_Post_State_In_Pragma
3541
3542 begin
3543 -- Examine all consequences
3544
3545 if Nam = Name_Contract_Cases then
3546 CCase := First (Component_Associations (Expr));
3547 while Present (CCase) loop
3548 Check_Expression (Expression (CCase));
3549
3550 Next (CCase);
3551 end loop;
3552
3553 -- Examine the expression of a postcondition
3554
3555 else pragma Assert (Nam_In (Nam, Name_Postcondition,
3556 Name_Refined_Post));
3557 Check_Expression (Expr);
3558 end if;
3559 end Check_Result_And_Post_State_In_Pragma;
3560
3561 --------------------------
3562 -- Has_In_Out_Parameter --
3563 --------------------------
3564
3565 function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is
3566 Formal : Entity_Id;
3567
3568 begin
3569 -- Traverse the formals looking for an IN OUT parameter
3570
3571 Formal := First_Formal (Subp_Id);
3572 while Present (Formal) loop
3573 if Ekind (Formal) = E_In_Out_Parameter then
3574 return True;
3575 end if;
3576
3577 Next_Formal (Formal);
3578 end loop;
3579
3580 return False;
3581 end Has_In_Out_Parameter;
3582
3583 -- Local variables
3584
3585 Items : constant Node_Id := Contract (Subp_Id);
3586 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
3587 Case_Prag : Node_Id := Empty;
3588 Post_Prag : Node_Id := Empty;
3589 Prag : Node_Id;
3590 Seen_In_Case : Boolean := False;
3591 Seen_In_Post : Boolean := False;
3592 Spec_Id : Entity_Id;
3593
3594 -- Start of processing for Check_Result_And_Post_State
3595
3596 begin
3597 -- The lack of attribute 'Result or a post-state is classified as a
3598 -- suspicious contract. Do not perform the check if the corresponding
3599 -- swich is not set.
3600
3601 if not Warn_On_Suspicious_Contract then
3602 return;
3603
3604 -- Nothing to do if there is no contract
3605
3606 elsif No (Items) then
3607 return;
3608 end if;
3609
3610 -- Retrieve the entity of the subprogram spec (if any)
3611
3612 if Nkind (Subp_Decl) = N_Subprogram_Body
3613 and then Present (Corresponding_Spec (Subp_Decl))
3614 then
3615 Spec_Id := Corresponding_Spec (Subp_Decl);
3616
3617 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
3618 and then Present (Corresponding_Spec_Of_Stub (Subp_Decl))
3619 then
3620 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
3621
3622 else
3623 Spec_Id := Subp_Id;
3624 end if;
3625
3626 -- Examine all postconditions for attribute 'Result and a post-state
3627
3628 Prag := Pre_Post_Conditions (Items);
3629 while Present (Prag) loop
3630 if Nam_In (Pragma_Name (Prag), Name_Postcondition,
3631 Name_Refined_Post)
3632 and then not Error_Posted (Prag)
3633 then
3634 Post_Prag := Prag;
3635 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post);
3636 end if;
3637
3638 Prag := Next_Pragma (Prag);
3639 end loop;
3640
3641 -- Examine the contract cases of the subprogram for attribute 'Result
3642 -- and a post-state.
3643
3644 Prag := Contract_Test_Cases (Items);
3645 while Present (Prag) loop
3646 if Pragma_Name (Prag) = Name_Contract_Cases
3647 and then not Error_Posted (Prag)
3648 then
3649 Case_Prag := Prag;
3650 Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case);
3651 end if;
3652
3653 Prag := Next_Pragma (Prag);
3654 end loop;
3655
3656 -- Do not emit any errors if the subprogram is not a function
3657
3658 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
3659 null;
3660
3661 -- Regardless of whether the function has postconditions or contract
3662 -- cases, or whether they mention attribute 'Result, an IN OUT formal
3663 -- parameter is always treated as a result.
3664
3665 elsif Has_In_Out_Parameter (Spec_Id) then
3666 null;
3667
3668 -- The function has both a postcondition and contract cases and they do
3669 -- not mention attribute 'Result.
3670
3671 elsif Present (Case_Prag)
3672 and then not Seen_In_Case
3673 and then Present (Post_Prag)
3674 and then not Seen_In_Post
3675 then
3676 Error_Msg_N
3677 ("neither postcondition nor contract cases mention function "
3678 & "result?T?", Post_Prag);
3679
3680 -- The function has contract cases only and they do not mention
3681 -- attribute 'Result.
3682
3683 elsif Present (Case_Prag) and then not Seen_In_Case then
3684 Error_Msg_N ("contract cases do not mention result?T?", Case_Prag);
3685
3686 -- The function has postconditions only and they do not mention
3687 -- attribute 'Result.
3688
3689 elsif Present (Post_Prag) and then not Seen_In_Post then
3690 Error_Msg_N
3691 ("postcondition does not mention function result?T?", Post_Prag);
3692 end if;
3693 end Check_Result_And_Post_State;
3694
3695 -----------------------------
3696 -- Check_State_Refinements --
3697 -----------------------------
3698
3699 procedure Check_State_Refinements
3700 (Context : Node_Id;
3701 Is_Main_Unit : Boolean := False)
3702 is
3703 procedure Check_Package (Pack : Node_Id);
3704 -- Verify that all abstract states of a [generic] package denoted by its
3705 -- declarative node Pack have proper refinement. Recursively verify the
3706 -- visible and private declarations of the [generic] package for other
3707 -- nested packages.
3708
3709 procedure Check_Packages_In (Decls : List_Id);
3710 -- Seek out [generic] package declarations within declarative list Decls
3711 -- and verify the status of their abstract state refinement.
3712
3713 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean;
3714 -- Determine whether construct N is subject to pragma SPARK_Mode Off
3715
3716 -------------------
3717 -- Check_Package --
3718 -------------------
3719
3720 procedure Check_Package (Pack : Node_Id) is
3721 Body_Id : constant Entity_Id := Corresponding_Body (Pack);
3722 Spec : constant Node_Id := Specification (Pack);
3723 States : constant Elist_Id :=
3724 Abstract_States (Defining_Entity (Pack));
3725
3726 State_Elmt : Elmt_Id;
3727 State_Id : Entity_Id;
3728
3729 begin
3730 -- Do not verify proper state refinement when the package is subject
3731 -- to pragma SPARK_Mode Off because this disables the requirement for
3732 -- state refinement.
3733
3734 if SPARK_Mode_Is_Off (Pack) then
3735 null;
3736
3737 -- State refinement can only occur in a completing packge body. Do
3738 -- not verify proper state refinement when the body is subject to
3739 -- pragma SPARK_Mode Off because this disables the requirement for
3740 -- state refinement.
3741
3742 elsif Present (Body_Id)
3743 and then SPARK_Mode_Is_Off (Unit_Declaration_Node (Body_Id))
3744 then
3745 null;
3746
3747 -- Do not verify proper state refinement when the package is an
3748 -- instance as this check was already performed in the generic.
3749
3750 elsif Present (Generic_Parent (Spec)) then
3751 null;
3752
3753 -- Otherwise examine the contents of the package
3754
3755 else
3756 if Present (States) then
3757 State_Elmt := First_Elmt (States);
3758 while Present (State_Elmt) loop
3759 State_Id := Node (State_Elmt);
3760
3761 -- Emit an error when a non-null state lacks any form of
3762 -- refinement.
3763
3764 if not Is_Null_State (State_Id)
3765 and then not Has_Null_Refinement (State_Id)
3766 and then not Has_Non_Null_Refinement (State_Id)
3767 then
3768 Error_Msg_N ("state & requires refinement", State_Id);
3769 end if;
3770
3771 Next_Elmt (State_Elmt);
3772 end loop;
3773 end if;
3774
3775 Check_Packages_In (Visible_Declarations (Spec));
3776 Check_Packages_In (Private_Declarations (Spec));
3777 end if;
3778 end Check_Package;
3779
3780 -----------------------
3781 -- Check_Packages_In --
3782 -----------------------
3783
3784 procedure Check_Packages_In (Decls : List_Id) is
3785 Decl : Node_Id;
3786
3787 begin
3788 if Present (Decls) then
3789 Decl := First (Decls);
3790 while Present (Decl) loop
3791 if Nkind_In (Decl, N_Generic_Package_Declaration,
3792 N_Package_Declaration)
3793 then
3794 Check_Package (Decl);
3795 end if;
3796
3797 Next (Decl);
3798 end loop;
3799 end if;
3800 end Check_Packages_In;
3801
3802 -----------------------
3803 -- SPARK_Mode_Is_Off --
3804 -----------------------
3805
3806 function SPARK_Mode_Is_Off (N : Node_Id) return Boolean is
3807 Prag : constant Node_Id := SPARK_Pragma (Defining_Entity (N));
3808
3809 begin
3810 return
3811 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = Off;
3812 end SPARK_Mode_Is_Off;
3813
3814 -- Start of processing for Check_State_Refinements
3815
3816 begin
3817 -- A block may declare a nested package
3818
3819 if Nkind (Context) = N_Block_Statement then
3820 Check_Packages_In (Declarations (Context));
3821
3822 -- An entry, protected, subprogram, or task body may declare a nested
3823 -- package.
3824
3825 elsif Nkind_In (Context, N_Entry_Body,
3826 N_Protected_Body,
3827 N_Subprogram_Body,
3828 N_Task_Body)
3829 then
3830 -- Do not verify proper state refinement when the body is subject to
3831 -- pragma SPARK_Mode Off because this disables the requirement for
3832 -- state refinement.
3833
3834 if not SPARK_Mode_Is_Off (Context) then
3835 Check_Packages_In (Declarations (Context));
3836 end if;
3837
3838 -- A package body may declare a nested package
3839
3840 elsif Nkind (Context) = N_Package_Body then
3841 Check_Package (Unit_Declaration_Node (Corresponding_Spec (Context)));
3842
3843 -- Do not verify proper state refinement when the body is subject to
3844 -- pragma SPARK_Mode Off because this disables the requirement for
3845 -- state refinement.
3846
3847 if not SPARK_Mode_Is_Off (Context) then
3848 Check_Packages_In (Declarations (Context));
3849 end if;
3850
3851 -- A library level [generic] package may declare a nested package
3852
3853 elsif Nkind_In (Context, N_Generic_Package_Declaration,
3854 N_Package_Declaration)
3855 and then Is_Main_Unit
3856 then
3857 Check_Package (Context);
3858 end if;
3859 end Check_State_Refinements;
3860
3861 ------------------------------
3862 -- Check_Unprotected_Access --
3863 ------------------------------
3864
3865 procedure Check_Unprotected_Access
3866 (Context : Node_Id;
3867 Expr : Node_Id)
3868 is
3869 Cont_Encl_Typ : Entity_Id;
3870 Pref_Encl_Typ : Entity_Id;
3871
3872 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
3873 -- Check whether Obj is a private component of a protected object.
3874 -- Return the protected type where the component resides, Empty
3875 -- otherwise.
3876
3877 function Is_Public_Operation return Boolean;
3878 -- Verify that the enclosing operation is callable from outside the
3879 -- protected object, to minimize false positives.
3880
3881 ------------------------------
3882 -- Enclosing_Protected_Type --
3883 ------------------------------
3884
3885 function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
3886 begin
3887 if Is_Entity_Name (Obj) then
3888 declare
3889 Ent : Entity_Id := Entity (Obj);
3890
3891 begin
3892 -- The object can be a renaming of a private component, use
3893 -- the original record component.
3894
3895 if Is_Prival (Ent) then
3896 Ent := Prival_Link (Ent);
3897 end if;
3898
3899 if Is_Protected_Type (Scope (Ent)) then
3900 return Scope (Ent);
3901 end if;
3902 end;
3903 end if;
3904
3905 -- For indexed and selected components, recursively check the prefix
3906
3907 if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
3908 return Enclosing_Protected_Type (Prefix (Obj));
3909
3910 -- The object does not denote a protected component
3911
3912 else
3913 return Empty;
3914 end if;
3915 end Enclosing_Protected_Type;
3916
3917 -------------------------
3918 -- Is_Public_Operation --
3919 -------------------------
3920
3921 function Is_Public_Operation return Boolean is
3922 S : Entity_Id;
3923 E : Entity_Id;
3924
3925 begin
3926 S := Current_Scope;
3927 while Present (S) and then S /= Pref_Encl_Typ loop
3928 if Scope (S) = Pref_Encl_Typ then
3929 E := First_Entity (Pref_Encl_Typ);
3930 while Present (E)
3931 and then E /= First_Private_Entity (Pref_Encl_Typ)
3932 loop
3933 if E = S then
3934 return True;
3935 end if;
3936
3937 Next_Entity (E);
3938 end loop;
3939 end if;
3940
3941 S := Scope (S);
3942 end loop;
3943
3944 return False;
3945 end Is_Public_Operation;
3946
3947 -- Start of processing for Check_Unprotected_Access
3948
3949 begin
3950 if Nkind (Expr) = N_Attribute_Reference
3951 and then Attribute_Name (Expr) = Name_Unchecked_Access
3952 then
3953 Cont_Encl_Typ := Enclosing_Protected_Type (Context);
3954 Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
3955
3956 -- Check whether we are trying to export a protected component to a
3957 -- context with an equal or lower access level.
3958
3959 if Present (Pref_Encl_Typ)
3960 and then No (Cont_Encl_Typ)
3961 and then Is_Public_Operation
3962 and then Scope_Depth (Pref_Encl_Typ) >=
3963 Object_Access_Level (Context)
3964 then
3965 Error_Msg_N
3966 ("??possible unprotected access to protected data", Expr);
3967 end if;
3968 end if;
3969 end Check_Unprotected_Access;
3970
3971 ------------------------------
3972 -- Check_Unused_Body_States --
3973 ------------------------------
3974
3975 procedure Check_Unused_Body_States (Body_Id : Entity_Id) is
3976 procedure Process_Refinement_Clause
3977 (Clause : Node_Id;
3978 States : Elist_Id);
3979 -- Inspect all constituents of refinement clause Clause and remove any
3980 -- matches from body state list States.
3981
3982 procedure Report_Unused_Body_States (States : Elist_Id);
3983 -- Emit errors for each abstract state or object found in list States
3984
3985 -------------------------------
3986 -- Process_Refinement_Clause --
3987 -------------------------------
3988
3989 procedure Process_Refinement_Clause
3990 (Clause : Node_Id;
3991 States : Elist_Id)
3992 is
3993 procedure Process_Constituent (Constit : Node_Id);
3994 -- Remove constituent Constit from body state list States
3995
3996 -------------------------
3997 -- Process_Constituent --
3998 -------------------------
3999
4000 procedure Process_Constituent (Constit : Node_Id) is
4001 Constit_Id : Entity_Id;
4002
4003 begin
4004 -- Guard against illegal constituents. Only abstract states and
4005 -- objects can appear on the right hand side of a refinement.
4006
4007 if Is_Entity_Name (Constit) then
4008 Constit_Id := Entity_Of (Constit);
4009
4010 if Present (Constit_Id)
4011 and then Ekind_In (Constit_Id, E_Abstract_State,
4012 E_Constant,
4013 E_Variable)
4014 then
4015 Remove (States, Constit_Id);
4016 end if;
4017 end if;
4018 end Process_Constituent;
4019
4020 -- Local variables
4021
4022 Constit : Node_Id;
4023
4024 -- Start of processing for Process_Refinement_Clause
4025
4026 begin
4027 if Nkind (Clause) = N_Component_Association then
4028 Constit := Expression (Clause);
4029
4030 -- Multiple constituents appear as an aggregate
4031
4032 if Nkind (Constit) = N_Aggregate then
4033 Constit := First (Expressions (Constit));
4034 while Present (Constit) loop
4035 Process_Constituent (Constit);
4036 Next (Constit);
4037 end loop;
4038
4039 -- Various forms of a single constituent
4040
4041 else
4042 Process_Constituent (Constit);
4043 end if;
4044 end if;
4045 end Process_Refinement_Clause;
4046
4047 -------------------------------
4048 -- Report_Unused_Body_States --
4049 -------------------------------
4050
4051 procedure Report_Unused_Body_States (States : Elist_Id) is
4052 Posted : Boolean := False;
4053 State_Elmt : Elmt_Id;
4054 State_Id : Entity_Id;
4055
4056 begin
4057 if Present (States) then
4058 State_Elmt := First_Elmt (States);
4059 while Present (State_Elmt) loop
4060 State_Id := Node (State_Elmt);
4061
4062 -- Constants are part of the hidden state of a package, but the
4063 -- compiler cannot determine whether they have variable input
4064 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
4065 -- hidden state. Do not emit an error when a constant does not
4066 -- participate in a state refinement, even though it acts as a
4067 -- hidden state.
4068
4069 if Ekind (State_Id) = E_Constant then
4070 null;
4071
4072 -- Generate an error message of the form:
4073
4074 -- body of package ... has unused hidden states
4075 -- abstract state ... defined at ...
4076 -- variable ... defined at ...
4077
4078 else
4079 if not Posted then
4080 Posted := True;
4081 SPARK_Msg_N
4082 ("body of package & has unused hidden states", Body_Id);
4083 end if;
4084
4085 Error_Msg_Sloc := Sloc (State_Id);
4086
4087 if Ekind (State_Id) = E_Abstract_State then
4088 SPARK_Msg_NE
4089 ("\abstract state & defined #", Body_Id, State_Id);
4090
4091 else
4092 SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id);
4093 end if;
4094 end if;
4095
4096 Next_Elmt (State_Elmt);
4097 end loop;
4098 end if;
4099 end Report_Unused_Body_States;
4100
4101 -- Local variables
4102
4103 Prag : constant Node_Id := Get_Pragma (Body_Id, Pragma_Refined_State);
4104 Spec_Id : constant Entity_Id := Spec_Entity (Body_Id);
4105 Clause : Node_Id;
4106 States : Elist_Id;
4107
4108 -- Start of processing for Check_Unused_Body_States
4109
4110 begin
4111 -- Inspect the clauses of pragma Refined_State and determine whether all
4112 -- visible states declared within the package body participate in the
4113 -- refinement.
4114
4115 if Present (Prag) then
4116 Clause := Expression (Get_Argument (Prag, Spec_Id));
4117 States := Collect_Body_States (Body_Id);
4118
4119 -- Multiple non-null state refinements appear as an aggregate
4120
4121 if Nkind (Clause) = N_Aggregate then
4122 Clause := First (Component_Associations (Clause));
4123 while Present (Clause) loop
4124 Process_Refinement_Clause (Clause, States);
4125 Next (Clause);
4126 end loop;
4127
4128 -- Various forms of a single state refinement
4129
4130 else
4131 Process_Refinement_Clause (Clause, States);
4132 end if;
4133
4134 -- Ensure that all abstract states and objects declared in the
4135 -- package body state space are utilized as constituents.
4136
4137 Report_Unused_Body_States (States);
4138 end if;
4139 end Check_Unused_Body_States;
4140
4141 -------------------------
4142 -- Collect_Body_States --
4143 -------------------------
4144
4145 function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id is
4146 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean;
4147 -- Determine whether object Obj_Id is a suitable visible state of a
4148 -- package body.
4149
4150 procedure Collect_Visible_States
4151 (Pack_Id : Entity_Id;
4152 States : in out Elist_Id);
4153 -- Gather the entities of all abstract states and objects declared in
4154 -- the visible state space of package Pack_Id.
4155
4156 ----------------------------
4157 -- Collect_Visible_States --
4158 ----------------------------
4159
4160 procedure Collect_Visible_States
4161 (Pack_Id : Entity_Id;
4162 States : in out Elist_Id)
4163 is
4164 Item_Id : Entity_Id;
4165
4166 begin
4167 -- Traverse the entity chain of the package and inspect all visible
4168 -- items.
4169
4170 Item_Id := First_Entity (Pack_Id);
4171 while Present (Item_Id) and then not In_Private_Part (Item_Id) loop
4172
4173 -- Do not consider internally generated items as those cannot be
4174 -- named and participate in refinement.
4175
4176 if not Comes_From_Source (Item_Id) then
4177 null;
4178
4179 elsif Ekind (Item_Id) = E_Abstract_State then
4180 Append_New_Elmt (Item_Id, States);
4181
4182 elsif Ekind_In (Item_Id, E_Constant, E_Variable)
4183 and then Is_Visible_Object (Item_Id)
4184 then
4185 Append_New_Elmt (Item_Id, States);
4186
4187 -- Recursively gather the visible states of a nested package
4188
4189 elsif Ekind (Item_Id) = E_Package then
4190 Collect_Visible_States (Item_Id, States);
4191 end if;
4192
4193 Next_Entity (Item_Id);
4194 end loop;
4195 end Collect_Visible_States;
4196
4197 -----------------------
4198 -- Is_Visible_Object --
4199 -----------------------
4200
4201 function Is_Visible_Object (Obj_Id : Entity_Id) return Boolean is
4202 begin
4203 -- Objects that map generic formals to their actuals are not visible
4204 -- from outside the generic instantiation.
4205
4206 if Present (Corresponding_Generic_Association
4207 (Declaration_Node (Obj_Id)))
4208 then
4209 return False;
4210
4211 -- Constituents of a single protected/task type act as components of
4212 -- the type and are not visible from outside the type.
4213
4214 elsif Ekind (Obj_Id) = E_Variable
4215 and then Present (Encapsulating_State (Obj_Id))
4216 and then Is_Single_Concurrent_Object (Encapsulating_State (Obj_Id))
4217 then
4218 return False;
4219
4220 else
4221 return True;
4222 end if;
4223 end Is_Visible_Object;
4224
4225 -- Local variables
4226
4227 Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id);
4228 Decl : Node_Id;
4229 Item_Id : Entity_Id;
4230 States : Elist_Id := No_Elist;
4231
4232 -- Start of processing for Collect_Body_States
4233
4234 begin
4235 -- Inspect the declarations of the body looking for source objects,
4236 -- packages and package instantiations. Note that even though this
4237 -- processing is very similar to Collect_Visible_States, a package
4238 -- body does not have a First/Next_Entity list.
4239
4240 Decl := First (Declarations (Body_Decl));
4241 while Present (Decl) loop
4242
4243 -- Capture source objects as internally generated temporaries cannot
4244 -- be named and participate in refinement.
4245
4246 if Nkind (Decl) = N_Object_Declaration then
4247 Item_Id := Defining_Entity (Decl);
4248
4249 if Comes_From_Source (Item_Id)
4250 and then Is_Visible_Object (Item_Id)
4251 then
4252 Append_New_Elmt (Item_Id, States);
4253 end if;
4254
4255 -- Capture the visible abstract states and objects of a source
4256 -- package [instantiation].
4257
4258 elsif Nkind (Decl) = N_Package_Declaration then
4259 Item_Id := Defining_Entity (Decl);
4260
4261 if Comes_From_Source (Item_Id) then
4262 Collect_Visible_States (Item_Id, States);
4263 end if;
4264 end if;
4265
4266 Next (Decl);
4267 end loop;
4268
4269 return States;
4270 end Collect_Body_States;
4271
4272 ------------------------
4273 -- Collect_Interfaces --
4274 ------------------------
4275
4276 procedure Collect_Interfaces
4277 (T : Entity_Id;
4278 Ifaces_List : out Elist_Id;
4279 Exclude_Parents : Boolean := False;
4280 Use_Full_View : Boolean := True)
4281 is
4282 procedure Collect (Typ : Entity_Id);
4283 -- Subsidiary subprogram used to traverse the whole list
4284 -- of directly and indirectly implemented interfaces
4285
4286 -------------
4287 -- Collect --
4288 -------------
4289
4290 procedure Collect (Typ : Entity_Id) is
4291 Ancestor : Entity_Id;
4292 Full_T : Entity_Id;
4293 Id : Node_Id;
4294 Iface : Entity_Id;
4295
4296 begin
4297 Full_T := Typ;
4298
4299 -- Handle private types and subtypes
4300
4301 if Use_Full_View
4302 and then Is_Private_Type (Typ)
4303 and then Present (Full_View (Typ))
4304 then
4305 Full_T := Full_View (Typ);
4306
4307 if Ekind (Full_T) = E_Record_Subtype then
4308 Full_T := Etype (Typ);
4309
4310 if Present (Full_View (Full_T)) then
4311 Full_T := Full_View (Full_T);
4312 end if;
4313 end if;
4314 end if;
4315
4316 -- Include the ancestor if we are generating the whole list of
4317 -- abstract interfaces.
4318
4319 if Etype (Full_T) /= Typ
4320
4321 -- Protect the frontend against wrong sources. For example:
4322
4323 -- package P is
4324 -- type A is tagged null record;
4325 -- type B is new A with private;
4326 -- type C is new A with private;
4327 -- private
4328 -- type B is new C with null record;
4329 -- type C is new B with null record;
4330 -- end P;
4331
4332 and then Etype (Full_T) /= T
4333 then
4334 Ancestor := Etype (Full_T);
4335 Collect (Ancestor);
4336
4337 if Is_Interface (Ancestor) and then not Exclude_Parents then
4338 Append_Unique_Elmt (Ancestor, Ifaces_List);
4339 end if;
4340 end if;
4341
4342 -- Traverse the graph of ancestor interfaces
4343
4344 if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
4345 Id := First (Abstract_Interface_List (Full_T));
4346 while Present (Id) loop
4347 Iface := Etype (Id);
4348
4349 -- Protect against wrong uses. For example:
4350 -- type I is interface;
4351 -- type O is tagged null record;
4352 -- type Wrong is new I and O with null record; -- ERROR
4353
4354 if Is_Interface (Iface) then
4355 if Exclude_Parents
4356 and then Etype (T) /= T
4357 and then Interface_Present_In_Ancestor (Etype (T), Iface)
4358 then
4359 null;
4360 else
4361 Collect (Iface);
4362 Append_Unique_Elmt (Iface, Ifaces_List);
4363 end if;
4364 end if;
4365
4366 Next (Id);
4367 end loop;
4368 end if;
4369 end Collect;
4370
4371 -- Start of processing for Collect_Interfaces
4372
4373 begin
4374 pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
4375 Ifaces_List := New_Elmt_List;
4376 Collect (T);
4377 end Collect_Interfaces;
4378
4379 ----------------------------------
4380 -- Collect_Interface_Components --
4381 ----------------------------------
4382
4383 procedure Collect_Interface_Components
4384 (Tagged_Type : Entity_Id;
4385 Components_List : out Elist_Id)
4386 is
4387 procedure Collect (Typ : Entity_Id);
4388 -- Subsidiary subprogram used to climb to the parents
4389
4390 -------------
4391 -- Collect --
4392 -------------
4393
4394 procedure Collect (Typ : Entity_Id) is
4395 Tag_Comp : Entity_Id;
4396 Parent_Typ : Entity_Id;
4397
4398 begin
4399 -- Handle private types
4400
4401 if Present (Full_View (Etype (Typ))) then
4402 Parent_Typ := Full_View (Etype (Typ));
4403 else
4404 Parent_Typ := Etype (Typ);
4405 end if;
4406
4407 if Parent_Typ /= Typ
4408
4409 -- Protect the frontend against wrong sources. For example:
4410
4411 -- package P is
4412 -- type A is tagged null record;
4413 -- type B is new A with private;
4414 -- type C is new A with private;
4415 -- private
4416 -- type B is new C with null record;
4417 -- type C is new B with null record;
4418 -- end P;
4419
4420 and then Parent_Typ /= Tagged_Type
4421 then
4422 Collect (Parent_Typ);
4423 end if;
4424
4425 -- Collect the components containing tags of secondary dispatch
4426 -- tables.
4427
4428 Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
4429 while Present (Tag_Comp) loop
4430 pragma Assert (Present (Related_Type (Tag_Comp)));
4431 Append_Elmt (Tag_Comp, Components_List);
4432
4433 Tag_Comp := Next_Tag_Component (Tag_Comp);
4434 end loop;
4435 end Collect;
4436
4437 -- Start of processing for Collect_Interface_Components
4438
4439 begin
4440 pragma Assert (Ekind (Tagged_Type) = E_Record_Type
4441 and then Is_Tagged_Type (Tagged_Type));
4442
4443 Components_List := New_Elmt_List;
4444 Collect (Tagged_Type);
4445 end Collect_Interface_Components;
4446
4447 -----------------------------
4448 -- Collect_Interfaces_Info --
4449 -----------------------------
4450
4451 procedure Collect_Interfaces_Info
4452 (T : Entity_Id;
4453 Ifaces_List : out Elist_Id;
4454 Components_List : out Elist_Id;
4455 Tags_List : out Elist_Id)
4456 is
4457 Comps_List : Elist_Id;
4458 Comp_Elmt : Elmt_Id;
4459 Comp_Iface : Entity_Id;
4460 Iface_Elmt : Elmt_Id;
4461 Iface : Entity_Id;
4462
4463 function Search_Tag (Iface : Entity_Id) return Entity_Id;
4464 -- Search for the secondary tag associated with the interface type
4465 -- Iface that is implemented by T.
4466
4467 ----------------
4468 -- Search_Tag --
4469 ----------------
4470
4471 function Search_Tag (Iface : Entity_Id) return Entity_Id is
4472 ADT : Elmt_Id;
4473 begin
4474 if not Is_CPP_Class (T) then
4475 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
4476 else
4477 ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
4478 end if;
4479
4480 while Present (ADT)
4481 and then Is_Tag (Node (ADT))
4482 and then Related_Type (Node (ADT)) /= Iface
4483 loop
4484 -- Skip secondary dispatch table referencing thunks to user
4485 -- defined primitives covered by this interface.
4486
4487 pragma Assert (Has_Suffix (Node (ADT), 'P'));
4488 Next_Elmt (ADT);
4489
4490 -- Skip secondary dispatch tables of Ada types
4491
4492 if not Is_CPP_Class (T) then
4493
4494 -- Skip secondary dispatch table referencing thunks to
4495 -- predefined primitives.
4496
4497 pragma Assert (Has_Suffix (Node (ADT), 'Y'));
4498 Next_Elmt (ADT);
4499
4500 -- Skip secondary dispatch table referencing user-defined
4501 -- primitives covered by this interface.
4502
4503 pragma Assert (Has_Suffix (Node (ADT), 'D'));
4504 Next_Elmt (ADT);
4505
4506 -- Skip secondary dispatch table referencing predefined
4507 -- primitives.
4508
4509 pragma Assert (Has_Suffix (Node (ADT), 'Z'));
4510 Next_Elmt (ADT);
4511 end if;
4512 end loop;
4513
4514 pragma Assert (Is_Tag (Node (ADT)));
4515 return Node (ADT);
4516 end Search_Tag;
4517
4518 -- Start of processing for Collect_Interfaces_Info
4519
4520 begin
4521 Collect_Interfaces (T, Ifaces_List);
4522 Collect_Interface_Components (T, Comps_List);
4523
4524 -- Search for the record component and tag associated with each
4525 -- interface type of T.
4526
4527 Components_List := New_Elmt_List;
4528 Tags_List := New_Elmt_List;
4529
4530 Iface_Elmt := First_Elmt (Ifaces_List);
4531 while Present (Iface_Elmt) loop
4532 Iface := Node (Iface_Elmt);
4533
4534 -- Associate the primary tag component and the primary dispatch table
4535 -- with all the interfaces that are parents of T
4536
4537 if Is_Ancestor (Iface, T, Use_Full_View => True) then
4538 Append_Elmt (First_Tag_Component (T), Components_List);
4539 Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
4540
4541 -- Otherwise search for the tag component and secondary dispatch
4542 -- table of Iface
4543
4544 else
4545 Comp_Elmt := First_Elmt (Comps_List);
4546 while Present (Comp_Elmt) loop
4547 Comp_Iface := Related_Type (Node (Comp_Elmt));
4548
4549 if Comp_Iface = Iface
4550 or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
4551 then
4552 Append_Elmt (Node (Comp_Elmt), Components_List);
4553 Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
4554 exit;
4555 end if;
4556
4557 Next_Elmt (Comp_Elmt);
4558 end loop;
4559 pragma Assert (Present (Comp_Elmt));
4560 end if;
4561
4562 Next_Elmt (Iface_Elmt);
4563 end loop;
4564 end Collect_Interfaces_Info;
4565
4566 ---------------------
4567 -- Collect_Parents --
4568 ---------------------
4569
4570 procedure Collect_Parents
4571 (T : Entity_Id;
4572 List : out Elist_Id;
4573 Use_Full_View : Boolean := True)
4574 is
4575 Current_Typ : Entity_Id := T;
4576 Parent_Typ : Entity_Id;
4577
4578 begin
4579 List := New_Elmt_List;
4580
4581 -- No action if the if the type has no parents
4582
4583 if T = Etype (T) then
4584 return;
4585 end if;
4586
4587 loop
4588 Parent_Typ := Etype (Current_Typ);
4589
4590 if Is_Private_Type (Parent_Typ)
4591 and then Present (Full_View (Parent_Typ))
4592 and then Use_Full_View
4593 then
4594 Parent_Typ := Full_View (Base_Type (Parent_Typ));
4595 end if;
4596
4597 Append_Elmt (Parent_Typ, List);
4598
4599 exit when Parent_Typ = Current_Typ;
4600 Current_Typ := Parent_Typ;
4601 end loop;
4602 end Collect_Parents;
4603
4604 ----------------------------------
4605 -- Collect_Primitive_Operations --
4606 ----------------------------------
4607
4608 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
4609 B_Type : constant Entity_Id := Base_Type (T);
4610 B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
4611 B_Scope : Entity_Id := Scope (B_Type);
4612 Op_List : Elist_Id;
4613 Formal : Entity_Id;
4614 Is_Prim : Boolean;
4615 Is_Type_In_Pkg : Boolean;
4616 Formal_Derived : Boolean := False;
4617 Id : Entity_Id;
4618
4619 function Match (E : Entity_Id) return Boolean;
4620 -- True if E's base type is B_Type, or E is of an anonymous access type
4621 -- and the base type of its designated type is B_Type.
4622
4623 -----------
4624 -- Match --
4625 -----------
4626
4627 function Match (E : Entity_Id) return Boolean is
4628 Etyp : Entity_Id := Etype (E);
4629
4630 begin
4631 if Ekind (Etyp) = E_Anonymous_Access_Type then
4632 Etyp := Designated_Type (Etyp);
4633 end if;
4634
4635 -- In Ada 2012 a primitive operation may have a formal of an
4636 -- incomplete view of the parent type.
4637
4638 return Base_Type (Etyp) = B_Type
4639 or else
4640 (Ada_Version >= Ada_2012
4641 and then Ekind (Etyp) = E_Incomplete_Type
4642 and then Full_View (Etyp) = B_Type);
4643 end Match;
4644
4645 -- Start of processing for Collect_Primitive_Operations
4646
4647 begin
4648 -- For tagged types, the primitive operations are collected as they
4649 -- are declared, and held in an explicit list which is simply returned.
4650
4651 if Is_Tagged_Type (B_Type) then
4652 return Primitive_Operations (B_Type);
4653
4654 -- An untagged generic type that is a derived type inherits the
4655 -- primitive operations of its parent type. Other formal types only
4656 -- have predefined operators, which are not explicitly represented.
4657
4658 elsif Is_Generic_Type (B_Type) then
4659 if Nkind (B_Decl) = N_Formal_Type_Declaration
4660 and then Nkind (Formal_Type_Definition (B_Decl)) =
4661 N_Formal_Derived_Type_Definition
4662 then
4663 Formal_Derived := True;
4664 else
4665 return New_Elmt_List;
4666 end if;
4667 end if;
4668
4669 Op_List := New_Elmt_List;
4670
4671 if B_Scope = Standard_Standard then
4672 if B_Type = Standard_String then
4673 Append_Elmt (Standard_Op_Concat, Op_List);
4674
4675 elsif B_Type = Standard_Wide_String then
4676 Append_Elmt (Standard_Op_Concatw, Op_List);
4677
4678 else
4679 null;
4680 end if;
4681
4682 -- Locate the primitive subprograms of the type
4683
4684 else
4685 -- The primitive operations appear after the base type, except
4686 -- if the derivation happens within the private part of B_Scope
4687 -- and the type is a private type, in which case both the type
4688 -- and some primitive operations may appear before the base
4689 -- type, and the list of candidates starts after the type.
4690
4691 if In_Open_Scopes (B_Scope)
4692 and then Scope (T) = B_Scope
4693 and then In_Private_Part (B_Scope)
4694 then
4695 Id := Next_Entity (T);
4696
4697 -- In Ada 2012, If the type has an incomplete partial view, there
4698 -- may be primitive operations declared before the full view, so
4699 -- we need to start scanning from the incomplete view, which is
4700 -- earlier on the entity chain.
4701
4702 elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration
4703 and then Present (Incomplete_View (Parent (B_Type)))
4704 then
4705 Id := Defining_Entity (Incomplete_View (Parent (B_Type)));
4706
4707 -- If T is a derived from a type with an incomplete view declared
4708 -- elsewhere, that incomplete view is irrelevant, we want the
4709 -- operations in the scope of T.
4710
4711 if Scope (Id) /= Scope (B_Type) then
4712 Id := Next_Entity (B_Type);
4713 end if;
4714
4715 else
4716 Id := Next_Entity (B_Type);
4717 end if;
4718
4719 -- Set flag if this is a type in a package spec
4720
4721 Is_Type_In_Pkg :=
4722 Is_Package_Or_Generic_Package (B_Scope)
4723 and then
4724 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
4725 N_Package_Body;
4726
4727 while Present (Id) loop
4728
4729 -- Test whether the result type or any of the parameter types of
4730 -- each subprogram following the type match that type when the
4731 -- type is declared in a package spec, is a derived type, or the
4732 -- subprogram is marked as primitive. (The Is_Primitive test is
4733 -- needed to find primitives of nonderived types in declarative
4734 -- parts that happen to override the predefined "=" operator.)
4735
4736 -- Note that generic formal subprograms are not considered to be
4737 -- primitive operations and thus are never inherited.
4738
4739 if Is_Overloadable (Id)
4740 and then (Is_Type_In_Pkg
4741 or else Is_Derived_Type (B_Type)
4742 or else Is_Primitive (Id))
4743 and then Nkind (Parent (Parent (Id)))
4744 not in N_Formal_Subprogram_Declaration
4745 then
4746 Is_Prim := False;
4747
4748 if Match (Id) then
4749 Is_Prim := True;
4750
4751 else
4752 Formal := First_Formal (Id);
4753 while Present (Formal) loop
4754 if Match (Formal) then
4755 Is_Prim := True;
4756 exit;
4757 end if;
4758
4759 Next_Formal (Formal);
4760 end loop;
4761 end if;
4762
4763 -- For a formal derived type, the only primitives are the ones
4764 -- inherited from the parent type. Operations appearing in the
4765 -- package declaration are not primitive for it.
4766
4767 if Is_Prim
4768 and then (not Formal_Derived or else Present (Alias (Id)))
4769 then
4770 -- In the special case of an equality operator aliased to
4771 -- an overriding dispatching equality belonging to the same
4772 -- type, we don't include it in the list of primitives.
4773 -- This avoids inheriting multiple equality operators when
4774 -- deriving from untagged private types whose full type is
4775 -- tagged, which can otherwise cause ambiguities. Note that
4776 -- this should only happen for this kind of untagged parent
4777 -- type, since normally dispatching operations are inherited
4778 -- using the type's Primitive_Operations list.
4779
4780 if Chars (Id) = Name_Op_Eq
4781 and then Is_Dispatching_Operation (Id)
4782 and then Present (Alias (Id))
4783 and then Present (Overridden_Operation (Alias (Id)))
4784 and then Base_Type (Etype (First_Entity (Id))) =
4785 Base_Type (Etype (First_Entity (Alias (Id))))
4786 then
4787 null;
4788
4789 -- Include the subprogram in the list of primitives
4790
4791 else
4792 Append_Elmt (Id, Op_List);
4793 end if;
4794 end if;
4795 end if;
4796
4797 Next_Entity (Id);
4798
4799 -- For a type declared in System, some of its operations may
4800 -- appear in the target-specific extension to System.
4801
4802 if No (Id)
4803 and then B_Scope = RTU_Entity (System)
4804 and then Present_System_Aux
4805 then
4806 B_Scope := System_Aux_Id;
4807 Id := First_Entity (System_Aux_Id);
4808 end if;
4809 end loop;
4810 end if;
4811
4812 return Op_List;
4813 end Collect_Primitive_Operations;
4814
4815 -----------------------------------
4816 -- Compile_Time_Constraint_Error --
4817 -----------------------------------
4818
4819 function Compile_Time_Constraint_Error
4820 (N : Node_Id;
4821 Msg : String;
4822 Ent : Entity_Id := Empty;
4823 Loc : Source_Ptr := No_Location;
4824 Warn : Boolean := False) return Node_Id
4825 is
4826 Msgc : String (1 .. Msg'Length + 3);
4827 -- Copy of message, with room for possible ?? or << and ! at end
4828
4829 Msgl : Natural;
4830 Wmsg : Boolean;
4831 Eloc : Source_Ptr;
4832
4833 -- Start of processing for Compile_Time_Constraint_Error
4834
4835 begin
4836 -- If this is a warning, convert it into an error if we are in code
4837 -- subject to SPARK_Mode being set On, unless Warn is True to force a
4838 -- warning. The rationale is that a compile-time constraint error should
4839 -- lead to an error instead of a warning when SPARK_Mode is On, but in
4840 -- a few cases we prefer to issue a warning and generate both a suitable
4841 -- run-time error in GNAT and a suitable check message in GNATprove.
4842 -- Those cases are those that likely correspond to deactivated SPARK
4843 -- code, so that this kind of code can be compiled and analyzed instead
4844 -- of being rejected.
4845
4846 Error_Msg_Warn := Warn or SPARK_Mode /= On;
4847
4848 -- A static constraint error in an instance body is not a fatal error.
4849 -- we choose to inhibit the message altogether, because there is no
4850 -- obvious node (for now) on which to post it. On the other hand the
4851 -- offending node must be replaced with a constraint_error in any case.
4852
4853 -- No messages are generated if we already posted an error on this node
4854
4855 if not Error_Posted (N) then
4856 if Loc /= No_Location then
4857 Eloc := Loc;
4858 else
4859 Eloc := Sloc (N);
4860 end if;
4861
4862 -- Copy message to Msgc, converting any ? in the message into
4863 -- < instead, so that we have an error in GNATprove mode.
4864
4865 Msgl := Msg'Length;
4866
4867 for J in 1 .. Msgl loop
4868 if Msg (J) = '?' and then (J = 1 or else Msg (J - 1) /= ''') then
4869 Msgc (J) := '<';
4870 else
4871 Msgc (J) := Msg (J);
4872 end if;
4873 end loop;
4874
4875 -- Message is a warning, even in Ada 95 case
4876
4877 if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then
4878 Wmsg := True;
4879
4880 -- In Ada 83, all messages are warnings. In the private part and
4881 -- the body of an instance, constraint_checks are only warnings.
4882 -- We also make this a warning if the Warn parameter is set.
4883
4884 elsif Warn
4885 or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
4886 then
4887 Msgl := Msgl + 1;
4888 Msgc (Msgl) := '<';
4889 Msgl := Msgl + 1;
4890 Msgc (Msgl) := '<';
4891 Wmsg := True;
4892
4893 elsif In_Instance_Not_Visible then
4894 Msgl := Msgl + 1;
4895 Msgc (Msgl) := '<';
4896 Msgl := Msgl + 1;
4897 Msgc (Msgl) := '<';
4898 Wmsg := True;
4899
4900 -- Otherwise we have a real error message (Ada 95 static case)
4901 -- and we make this an unconditional message. Note that in the
4902 -- warning case we do not make the message unconditional, it seems
4903 -- quite reasonable to delete messages like this (about exceptions
4904 -- that will be raised) in dead code.
4905
4906 else
4907 Wmsg := False;
4908 Msgl := Msgl + 1;
4909 Msgc (Msgl) := '!';
4910 end if;
4911
4912 -- One more test, skip the warning if the related expression is
4913 -- statically unevaluated, since we don't want to warn about what
4914 -- will happen when something is evaluated if it never will be
4915 -- evaluated.
4916
4917 if not Is_Statically_Unevaluated (N) then
4918 if Present (Ent) then
4919 Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
4920 else
4921 Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
4922 end if;
4923
4924 if Wmsg then
4925
4926 -- Check whether the context is an Init_Proc
4927
4928 if Inside_Init_Proc then
4929 declare
4930 Conc_Typ : constant Entity_Id :=
4931 Corresponding_Concurrent_Type
4932 (Entity (Parameter_Type (First
4933 (Parameter_Specifications
4934 (Parent (Current_Scope))))));
4935
4936 begin
4937 -- Don't complain if the corresponding concurrent type
4938 -- doesn't come from source (i.e. a single task/protected
4939 -- object).
4940
4941 if Present (Conc_Typ)
4942 and then not Comes_From_Source (Conc_Typ)
4943 then
4944 Error_Msg_NEL
4945 ("\& [<<", N, Standard_Constraint_Error, Eloc);
4946
4947 else
4948 if GNATprove_Mode then
4949 Error_Msg_NEL
4950 ("\& would have been raised for objects of this "
4951 & "type", N, Standard_Constraint_Error, Eloc);
4952 else
4953 Error_Msg_NEL
4954 ("\& will be raised for objects of this type??",
4955 N, Standard_Constraint_Error, Eloc);
4956 end if;
4957 end if;
4958 end;
4959
4960 else
4961 Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc);
4962 end if;
4963
4964 else
4965 Error_Msg ("\static expression fails Constraint_Check", Eloc);
4966 Set_Error_Posted (N);
4967 end if;
4968 end if;
4969 end if;
4970
4971 return N;
4972 end Compile_Time_Constraint_Error;
4973
4974 -----------------------
4975 -- Conditional_Delay --
4976 -----------------------
4977
4978 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
4979 begin
4980 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
4981 Set_Has_Delayed_Freeze (New_Ent);
4982 end if;
4983 end Conditional_Delay;
4984
4985 ----------------------------
4986 -- Contains_Refined_State --
4987 ----------------------------
4988
4989 function Contains_Refined_State (Prag : Node_Id) return Boolean is
4990 function Has_State_In_Dependency (List : Node_Id) return Boolean;
4991 -- Determine whether a dependency list mentions a state with a visible
4992 -- refinement.
4993
4994 function Has_State_In_Global (List : Node_Id) return Boolean;
4995 -- Determine whether a global list mentions a state with a visible
4996 -- refinement.
4997
4998 function Is_Refined_State (Item : Node_Id) return Boolean;
4999 -- Determine whether Item is a reference to an abstract state with a
5000 -- visible refinement.
5001
5002 -----------------------------
5003 -- Has_State_In_Dependency --
5004 -----------------------------
5005
5006 function Has_State_In_Dependency (List : Node_Id) return Boolean is
5007 Clause : Node_Id;
5008 Output : Node_Id;
5009
5010 begin
5011 -- A null dependency list does not mention any states
5012
5013 if Nkind (List) = N_Null then
5014 return False;
5015
5016 -- Dependency clauses appear as component associations of an
5017 -- aggregate.
5018
5019 elsif Nkind (List) = N_Aggregate
5020 and then Present (Component_Associations (List))
5021 then
5022 Clause := First (Component_Associations (List));
5023 while Present (Clause) loop
5024
5025 -- Inspect the outputs of a dependency clause
5026
5027 Output := First (Choices (Clause));
5028 while Present (Output) loop
5029 if Is_Refined_State (Output) then
5030 return True;
5031 end if;
5032
5033 Next (Output);
5034 end loop;
5035
5036 -- Inspect the outputs of a dependency clause
5037
5038 if Is_Refined_State (Expression (Clause)) then
5039 return True;
5040 end if;
5041
5042 Next (Clause);
5043 end loop;
5044
5045 -- If we get here, then none of the dependency clauses mention a
5046 -- state with visible refinement.
5047
5048 return False;
5049
5050 -- An illegal pragma managed to sneak in
5051
5052 else
5053 raise Program_Error;
5054 end if;
5055 end Has_State_In_Dependency;
5056
5057 -------------------------
5058 -- Has_State_In_Global --
5059 -------------------------
5060
5061 function Has_State_In_Global (List : Node_Id) return Boolean is
5062 Item : Node_Id;
5063
5064 begin
5065 -- A null global list does not mention any states
5066
5067 if Nkind (List) = N_Null then
5068 return False;
5069
5070 -- Simple global list or moded global list declaration
5071
5072 elsif Nkind (List) = N_Aggregate then
5073
5074 -- The declaration of a simple global list appear as a collection
5075 -- of expressions.
5076
5077 if Present (Expressions (List)) then
5078 Item := First (Expressions (List));
5079 while Present (Item) loop
5080 if Is_Refined_State (Item) then
5081 return True;
5082 end if;
5083
5084 Next (Item);
5085 end loop;
5086
5087 -- The declaration of a moded global list appears as a collection
5088 -- of component associations where individual choices denote
5089 -- modes.
5090
5091 else
5092 Item := First (Component_Associations (List));
5093 while Present (Item) loop
5094 if Has_State_In_Global (Expression (Item)) then
5095 return True;
5096 end if;
5097
5098 Next (Item);
5099 end loop;
5100 end if;
5101
5102 -- If we get here, then the simple/moded global list did not
5103 -- mention any states with a visible refinement.
5104
5105 return False;
5106
5107 -- Single global item declaration
5108
5109 elsif Is_Entity_Name (List) then
5110 return Is_Refined_State (List);
5111
5112 -- An illegal pragma managed to sneak in
5113
5114 else
5115 raise Program_Error;
5116 end if;
5117 end Has_State_In_Global;
5118
5119 ----------------------
5120 -- Is_Refined_State --
5121 ----------------------
5122
5123 function Is_Refined_State (Item : Node_Id) return Boolean is
5124 Elmt : Node_Id;
5125 Item_Id : Entity_Id;
5126
5127 begin
5128 if Nkind (Item) = N_Null then
5129 return False;
5130
5131 -- States cannot be subject to attribute 'Result. This case arises
5132 -- in dependency relations.
5133
5134 elsif Nkind (Item) = N_Attribute_Reference
5135 and then Attribute_Name (Item) = Name_Result
5136 then
5137 return False;
5138
5139 -- Multiple items appear as an aggregate. This case arises in
5140 -- dependency relations.
5141
5142 elsif Nkind (Item) = N_Aggregate
5143 and then Present (Expressions (Item))
5144 then
5145 Elmt := First (Expressions (Item));
5146 while Present (Elmt) loop
5147 if Is_Refined_State (Elmt) then
5148 return True;
5149 end if;
5150
5151 Next (Elmt);
5152 end loop;
5153
5154 -- If we get here, then none of the inputs or outputs reference a
5155 -- state with visible refinement.
5156
5157 return False;
5158
5159 -- Single item
5160
5161 else
5162 Item_Id := Entity_Of (Item);
5163
5164 return
5165 Present (Item_Id)
5166 and then Ekind (Item_Id) = E_Abstract_State
5167 and then Has_Visible_Refinement (Item_Id);
5168 end if;
5169 end Is_Refined_State;
5170
5171 -- Local variables
5172
5173 Arg : constant Node_Id :=
5174 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
5175 Nam : constant Name_Id := Pragma_Name (Prag);
5176
5177 -- Start of processing for Contains_Refined_State
5178
5179 begin
5180 if Nam = Name_Depends then
5181 return Has_State_In_Dependency (Arg);
5182
5183 else pragma Assert (Nam = Name_Global);
5184 return Has_State_In_Global (Arg);
5185 end if;
5186 end Contains_Refined_State;
5187
5188 -------------------------
5189 -- Copy_Component_List --
5190 -------------------------
5191
5192 function Copy_Component_List
5193 (R_Typ : Entity_Id;
5194 Loc : Source_Ptr) return List_Id
5195 is
5196 Comp : Node_Id;
5197 Comps : constant List_Id := New_List;
5198
5199 begin
5200 Comp := First_Component (Underlying_Type (R_Typ));
5201 while Present (Comp) loop
5202 if Comes_From_Source (Comp) then
5203 declare
5204 Comp_Decl : constant Node_Id := Declaration_Node (Comp);
5205 begin
5206 Append_To (Comps,
5207 Make_Component_Declaration (Loc,
5208 Defining_Identifier =>
5209 Make_Defining_Identifier (Loc, Chars (Comp)),
5210 Component_Definition =>
5211 New_Copy_Tree
5212 (Component_Definition (Comp_Decl), New_Sloc => Loc)));
5213 end;
5214 end if;
5215
5216 Next_Component (Comp);
5217 end loop;
5218
5219 return Comps;
5220 end Copy_Component_List;
5221
5222 -------------------------
5223 -- Copy_Parameter_List --
5224 -------------------------
5225
5226 function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
5227 Loc : constant Source_Ptr := Sloc (Subp_Id);
5228 Plist : List_Id;
5229 Formal : Entity_Id;
5230
5231 begin
5232 if No (First_Formal (Subp_Id)) then
5233 return No_List;
5234 else
5235 Plist := New_List;
5236 Formal := First_Formal (Subp_Id);
5237 while Present (Formal) loop
5238 Append_To (Plist,
5239 Make_Parameter_Specification (Loc,
5240 Defining_Identifier =>
5241 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
5242 In_Present => In_Present (Parent (Formal)),
5243 Out_Present => Out_Present (Parent (Formal)),
5244 Parameter_Type =>
5245 New_Occurrence_Of (Etype (Formal), Loc),
5246 Expression =>
5247 New_Copy_Tree (Expression (Parent (Formal)))));
5248
5249 Next_Formal (Formal);
5250 end loop;
5251 end if;
5252
5253 return Plist;
5254 end Copy_Parameter_List;
5255
5256 --------------------------
5257 -- Copy_Subprogram_Spec --
5258 --------------------------
5259
5260 function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is
5261 Def_Id : Node_Id;
5262 Formal_Spec : Node_Id;
5263 Result : Node_Id;
5264
5265 begin
5266 -- The structure of the original tree must be replicated without any
5267 -- alterations. Use New_Copy_Tree for this purpose.
5268
5269 Result := New_Copy_Tree (Spec);
5270
5271 -- Create a new entity for the defining unit name
5272
5273 Def_Id := Defining_Unit_Name (Result);
5274 Set_Defining_Unit_Name (Result,
5275 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
5276
5277 -- Create new entities for the formal parameters
5278
5279 if Present (Parameter_Specifications (Result)) then
5280 Formal_Spec := First (Parameter_Specifications (Result));
5281 while Present (Formal_Spec) loop
5282 Def_Id := Defining_Identifier (Formal_Spec);
5283 Set_Defining_Identifier (Formal_Spec,
5284 Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
5285
5286 Next (Formal_Spec);
5287 end loop;
5288 end if;
5289
5290 return Result;
5291 end Copy_Subprogram_Spec;
5292
5293 --------------------------------
5294 -- Corresponding_Generic_Type --
5295 --------------------------------
5296
5297 function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
5298 Inst : Entity_Id;
5299 Gen : Entity_Id;
5300 Typ : Entity_Id;
5301
5302 begin
5303 if not Is_Generic_Actual_Type (T) then
5304 return Any_Type;
5305
5306 -- If the actual is the actual of an enclosing instance, resolution
5307 -- was correct in the generic.
5308
5309 elsif Nkind (Parent (T)) = N_Subtype_Declaration
5310 and then Is_Entity_Name (Subtype_Indication (Parent (T)))
5311 and then
5312 Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T))))
5313 then
5314 return Any_Type;
5315
5316 else
5317 Inst := Scope (T);
5318
5319 if Is_Wrapper_Package (Inst) then
5320 Inst := Related_Instance (Inst);
5321 end if;
5322
5323 Gen :=
5324 Generic_Parent
5325 (Specification (Unit_Declaration_Node (Inst)));
5326
5327 -- Generic actual has the same name as the corresponding formal
5328
5329 Typ := First_Entity (Gen);
5330 while Present (Typ) loop
5331 if Chars (Typ) = Chars (T) then
5332 return Typ;
5333 end if;
5334
5335 Next_Entity (Typ);
5336 end loop;
5337
5338 return Any_Type;
5339 end if;
5340 end Corresponding_Generic_Type;
5341
5342 --------------------
5343 -- Current_Entity --
5344 --------------------
5345
5346 -- The currently visible definition for a given identifier is the
5347 -- one most chained at the start of the visibility chain, i.e. the
5348 -- one that is referenced by the Node_Id value of the name of the
5349 -- given identifier.
5350
5351 function Current_Entity (N : Node_Id) return Entity_Id is
5352 begin
5353 return Get_Name_Entity_Id (Chars (N));
5354 end Current_Entity;
5355
5356 -----------------------------
5357 -- Current_Entity_In_Scope --
5358 -----------------------------
5359
5360 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
5361 E : Entity_Id;
5362 CS : constant Entity_Id := Current_Scope;
5363
5364 Transient_Case : constant Boolean := Scope_Is_Transient;
5365
5366 begin
5367 E := Get_Name_Entity_Id (Chars (N));
5368 while Present (E)
5369 and then Scope (E) /= CS
5370 and then (not Transient_Case or else Scope (E) /= Scope (CS))
5371 loop
5372 E := Homonym (E);
5373 end loop;
5374
5375 return E;
5376 end Current_Entity_In_Scope;
5377
5378 -------------------
5379 -- Current_Scope --
5380 -------------------
5381
5382 function Current_Scope return Entity_Id is
5383 begin
5384 if Scope_Stack.Last = -1 then
5385 return Standard_Standard;
5386 else
5387 declare
5388 C : constant Entity_Id :=
5389 Scope_Stack.Table (Scope_Stack.Last).Entity;
5390 begin
5391 if Present (C) then
5392 return C;
5393 else
5394 return Standard_Standard;
5395 end if;
5396 end;
5397 end if;
5398 end Current_Scope;
5399
5400 ----------------------------
5401 -- Current_Scope_No_Loops --
5402 ----------------------------
5403
5404 function Current_Scope_No_Loops return Entity_Id is
5405 S : Entity_Id;
5406
5407 begin
5408 -- Examine the scope stack starting from the current scope and skip any
5409 -- internally generated loops.
5410
5411 S := Current_Scope;
5412 while Present (S) and then S /= Standard_Standard loop
5413 if Ekind (S) = E_Loop and then not Comes_From_Source (S) then
5414 S := Scope (S);
5415 else
5416 exit;
5417 end if;
5418 end loop;
5419
5420 return S;
5421 end Current_Scope_No_Loops;
5422
5423 ------------------------
5424 -- Current_Subprogram --
5425 ------------------------
5426
5427 function Current_Subprogram return Entity_Id is
5428 Scop : constant Entity_Id := Current_Scope;
5429 begin
5430 if Is_Subprogram_Or_Generic_Subprogram (Scop) then
5431 return Scop;
5432 else
5433 return Enclosing_Subprogram (Scop);
5434 end if;
5435 end Current_Subprogram;
5436
5437 ----------------------------------
5438 -- Deepest_Type_Access_Level --
5439 ----------------------------------
5440
5441 function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
5442 begin
5443 if Ekind (Typ) = E_Anonymous_Access_Type
5444 and then not Is_Local_Anonymous_Access (Typ)
5445 and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
5446 then
5447 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
5448 -- access type.
5449
5450 return
5451 Scope_Depth (Enclosing_Dynamic_Scope
5452 (Defining_Identifier
5453 (Associated_Node_For_Itype (Typ))));
5454
5455 -- For generic formal type, return Int'Last (infinite).
5456 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
5457
5458 elsif Is_Generic_Type (Root_Type (Typ)) then
5459 return UI_From_Int (Int'Last);
5460
5461 else
5462 return Type_Access_Level (Typ);
5463 end if;
5464 end Deepest_Type_Access_Level;
5465
5466 ---------------------
5467 -- Defining_Entity --
5468 ---------------------
5469
5470 function Defining_Entity
5471 (N : Node_Id;
5472 Empty_On_Errors : Boolean := False) return Entity_Id
5473 is
5474 Err : Entity_Id := Empty;
5475
5476 begin
5477 case Nkind (N) is
5478 when N_Abstract_Subprogram_Declaration |
5479 N_Expression_Function |
5480 N_Formal_Subprogram_Declaration |
5481 N_Generic_Package_Declaration |
5482 N_Generic_Subprogram_Declaration |
5483 N_Package_Declaration |
5484 N_Subprogram_Body |
5485 N_Subprogram_Body_Stub |
5486 N_Subprogram_Declaration |
5487 N_Subprogram_Renaming_Declaration
5488 =>
5489 return Defining_Entity (Specification (N));
5490
5491 when N_Component_Declaration |
5492 N_Defining_Program_Unit_Name |
5493 N_Discriminant_Specification |
5494 N_Entry_Body |
5495 N_Entry_Declaration |
5496 N_Entry_Index_Specification |
5497 N_Exception_Declaration |
5498 N_Exception_Renaming_Declaration |
5499 N_Formal_Object_Declaration |
5500 N_Formal_Package_Declaration |
5501 N_Formal_Type_Declaration |
5502 N_Full_Type_Declaration |
5503 N_Implicit_Label_Declaration |
5504 N_Incomplete_Type_Declaration |
5505 N_Loop_Parameter_Specification |
5506 N_Number_Declaration |
5507 N_Object_Declaration |
5508 N_Object_Renaming_Declaration |
5509 N_Package_Body_Stub |
5510 N_Parameter_Specification |
5511 N_Private_Extension_Declaration |
5512 N_Private_Type_Declaration |
5513 N_Protected_Body |
5514 N_Protected_Body_Stub |
5515 N_Protected_Type_Declaration |
5516 N_Single_Protected_Declaration |
5517 N_Single_Task_Declaration |
5518 N_Subtype_Declaration |
5519 N_Task_Body |
5520 N_Task_Body_Stub |
5521 N_Task_Type_Declaration
5522 =>
5523 return Defining_Identifier (N);
5524
5525 when N_Subunit =>
5526 return Defining_Entity (Proper_Body (N));
5527
5528 when N_Function_Instantiation |
5529 N_Function_Specification |
5530 N_Generic_Function_Renaming_Declaration |
5531 N_Generic_Package_Renaming_Declaration |
5532 N_Generic_Procedure_Renaming_Declaration |
5533 N_Package_Body |
5534 N_Package_Instantiation |
5535 N_Package_Renaming_Declaration |
5536 N_Package_Specification |
5537 N_Procedure_Instantiation |
5538 N_Procedure_Specification
5539 =>
5540 declare
5541 Nam : constant Node_Id := Defining_Unit_Name (N);
5542
5543 begin
5544 if Nkind (Nam) in N_Entity then
5545 return Nam;
5546
5547 -- For Error, make up a name and attach to declaration so we
5548 -- can continue semantic analysis.
5549
5550 elsif Nam = Error then
5551 if Empty_On_Errors then
5552 return Empty;
5553 else
5554 Err := Make_Temporary (Sloc (N), 'T');
5555 Set_Defining_Unit_Name (N, Err);
5556
5557 return Err;
5558 end if;
5559
5560 -- If not an entity, get defining identifier
5561
5562 else
5563 return Defining_Identifier (Nam);
5564 end if;
5565 end;
5566
5567 when N_Block_Statement |
5568 N_Loop_Statement =>
5569 return Entity (Identifier (N));
5570
5571 when others =>
5572 if Empty_On_Errors then
5573 return Empty;
5574 else
5575 raise Program_Error;
5576 end if;
5577
5578 end case;
5579 end Defining_Entity;
5580
5581 --------------------------
5582 -- Denotes_Discriminant --
5583 --------------------------
5584
5585 function Denotes_Discriminant
5586 (N : Node_Id;
5587 Check_Concurrent : Boolean := False) return Boolean
5588 is
5589 E : Entity_Id;
5590
5591 begin
5592 if not Is_Entity_Name (N) or else No (Entity (N)) then
5593 return False;
5594 else
5595 E := Entity (N);
5596 end if;
5597
5598 -- If we are checking for a protected type, the discriminant may have
5599 -- been rewritten as the corresponding discriminal of the original type
5600 -- or of the corresponding concurrent record, depending on whether we
5601 -- are in the spec or body of the protected type.
5602
5603 return Ekind (E) = E_Discriminant
5604 or else
5605 (Check_Concurrent
5606 and then Ekind (E) = E_In_Parameter
5607 and then Present (Discriminal_Link (E))
5608 and then
5609 (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
5610 or else
5611 Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
5612 end Denotes_Discriminant;
5613
5614 -------------------------
5615 -- Denotes_Same_Object --
5616 -------------------------
5617
5618 function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
5619 Obj1 : Node_Id := A1;
5620 Obj2 : Node_Id := A2;
5621
5622 function Has_Prefix (N : Node_Id) return Boolean;
5623 -- Return True if N has attribute Prefix
5624
5625 function Is_Renaming (N : Node_Id) return Boolean;
5626 -- Return true if N names a renaming entity
5627
5628 function Is_Valid_Renaming (N : Node_Id) return Boolean;
5629 -- For renamings, return False if the prefix of any dereference within
5630 -- the renamed object_name is a variable, or any expression within the
5631 -- renamed object_name contains references to variables or calls on
5632 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
5633
5634 ----------------
5635 -- Has_Prefix --
5636 ----------------
5637
5638 function Has_Prefix (N : Node_Id) return Boolean is
5639 begin
5640 return
5641 Nkind_In (N,
5642 N_Attribute_Reference,
5643 N_Expanded_Name,
5644 N_Explicit_Dereference,
5645 N_Indexed_Component,
5646 N_Reference,
5647 N_Selected_Component,
5648 N_Slice);
5649 end Has_Prefix;
5650
5651 -----------------
5652 -- Is_Renaming --
5653 -----------------
5654
5655 function Is_Renaming (N : Node_Id) return Boolean is
5656 begin
5657 return Is_Entity_Name (N)
5658 and then Present (Renamed_Entity (Entity (N)));
5659 end Is_Renaming;
5660
5661 -----------------------
5662 -- Is_Valid_Renaming --
5663 -----------------------
5664
5665 function Is_Valid_Renaming (N : Node_Id) return Boolean is
5666
5667 function Check_Renaming (N : Node_Id) return Boolean;
5668 -- Recursive function used to traverse all the prefixes of N
5669
5670 function Check_Renaming (N : Node_Id) return Boolean is
5671 begin
5672 if Is_Renaming (N)
5673 and then not Check_Renaming (Renamed_Entity (Entity (N)))
5674 then
5675 return False;
5676 end if;
5677
5678 if Nkind (N) = N_Indexed_Component then
5679 declare
5680 Indx : Node_Id;
5681
5682 begin
5683 Indx := First (Expressions (N));
5684 while Present (Indx) loop
5685 if not Is_OK_Static_Expression (Indx) then
5686 return False;
5687 end if;
5688
5689 Next_Index (Indx);
5690 end loop;
5691 end;
5692 end if;
5693
5694 if Has_Prefix (N) then
5695 declare
5696 P : constant Node_Id := Prefix (N);
5697
5698 begin
5699 if Nkind (N) = N_Explicit_Dereference
5700 and then Is_Variable (P)
5701 then
5702 return False;
5703
5704 elsif Is_Entity_Name (P)
5705 and then Ekind (Entity (P)) = E_Function
5706 then
5707 return False;
5708
5709 elsif Nkind (P) = N_Function_Call then
5710 return False;
5711 end if;
5712
5713 -- Recursion to continue traversing the prefix of the
5714 -- renaming expression
5715
5716 return Check_Renaming (P);
5717 end;
5718 end if;
5719
5720 return True;
5721 end Check_Renaming;
5722
5723 -- Start of processing for Is_Valid_Renaming
5724
5725 begin
5726 return Check_Renaming (N);
5727 end Is_Valid_Renaming;
5728
5729 -- Start of processing for Denotes_Same_Object
5730
5731 begin
5732 -- Both names statically denote the same stand-alone object or parameter
5733 -- (RM 6.4.1(6.5/3))
5734
5735 if Is_Entity_Name (Obj1)
5736 and then Is_Entity_Name (Obj2)
5737 and then Entity (Obj1) = Entity (Obj2)
5738 then
5739 return True;
5740 end if;
5741
5742 -- For renamings, the prefix of any dereference within the renamed
5743 -- object_name is not a variable, and any expression within the
5744 -- renamed object_name contains no references to variables nor
5745 -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
5746
5747 if Is_Renaming (Obj1) then
5748 if Is_Valid_Renaming (Obj1) then
5749 Obj1 := Renamed_Entity (Entity (Obj1));
5750 else
5751 return False;
5752 end if;
5753 end if;
5754
5755 if Is_Renaming (Obj2) then
5756 if Is_Valid_Renaming (Obj2) then
5757 Obj2 := Renamed_Entity (Entity (Obj2));
5758 else
5759 return False;
5760 end if;
5761 end if;
5762
5763 -- No match if not same node kind (such cases are handled by
5764 -- Denotes_Same_Prefix)
5765
5766 if Nkind (Obj1) /= Nkind (Obj2) then
5767 return False;
5768
5769 -- After handling valid renamings, one of the two names statically
5770 -- denoted a renaming declaration whose renamed object_name is known
5771 -- to denote the same object as the other (RM 6.4.1(6.10/3))
5772
5773 elsif Is_Entity_Name (Obj1) then
5774 if Is_Entity_Name (Obj2) then
5775 return Entity (Obj1) = Entity (Obj2);
5776 else
5777 return False;
5778 end if;
5779
5780 -- Both names are selected_components, their prefixes are known to
5781 -- denote the same object, and their selector_names denote the same
5782 -- component (RM 6.4.1(6.6/3)).
5783
5784 elsif Nkind (Obj1) = N_Selected_Component then
5785 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
5786 and then
5787 Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
5788
5789 -- Both names are dereferences and the dereferenced names are known to
5790 -- denote the same object (RM 6.4.1(6.7/3))
5791
5792 elsif Nkind (Obj1) = N_Explicit_Dereference then
5793 return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
5794
5795 -- Both names are indexed_components, their prefixes are known to denote
5796 -- the same object, and each of the pairs of corresponding index values
5797 -- are either both static expressions with the same static value or both
5798 -- names that are known to denote the same object (RM 6.4.1(6.8/3))
5799
5800 elsif Nkind (Obj1) = N_Indexed_Component then
5801 if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
5802 return False;
5803 else
5804 declare
5805 Indx1 : Node_Id;
5806 Indx2 : Node_Id;
5807
5808 begin
5809 Indx1 := First (Expressions (Obj1));
5810 Indx2 := First (Expressions (Obj2));
5811 while Present (Indx1) loop
5812
5813 -- Indexes must denote the same static value or same object
5814
5815 if Is_OK_Static_Expression (Indx1) then
5816 if not Is_OK_Static_Expression (Indx2) then
5817 return False;
5818
5819 elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
5820 return False;
5821 end if;
5822
5823 elsif not Denotes_Same_Object (Indx1, Indx2) then
5824 return False;
5825 end if;
5826
5827 Next (Indx1);
5828 Next (Indx2);
5829 end loop;
5830
5831 return True;
5832 end;
5833 end if;
5834
5835 -- Both names are slices, their prefixes are known to denote the same
5836 -- object, and the two slices have statically matching index constraints
5837 -- (RM 6.4.1(6.9/3))
5838
5839 elsif Nkind (Obj1) = N_Slice
5840 and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
5841 then
5842 declare
5843 Lo1, Lo2, Hi1, Hi2 : Node_Id;
5844
5845 begin
5846 Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
5847 Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
5848
5849 -- Check whether bounds are statically identical. There is no
5850 -- attempt to detect partial overlap of slices.
5851
5852 return Denotes_Same_Object (Lo1, Lo2)
5853 and then
5854 Denotes_Same_Object (Hi1, Hi2);
5855 end;
5856
5857 -- In the recursion, literals appear as indexes
5858
5859 elsif Nkind (Obj1) = N_Integer_Literal
5860 and then
5861 Nkind (Obj2) = N_Integer_Literal
5862 then
5863 return Intval (Obj1) = Intval (Obj2);
5864
5865 else
5866 return False;
5867 end if;
5868 end Denotes_Same_Object;
5869
5870 -------------------------
5871 -- Denotes_Same_Prefix --
5872 -------------------------
5873
5874 function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
5875 begin
5876 if Is_Entity_Name (A1) then
5877 if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
5878 and then not Is_Access_Type (Etype (A1))
5879 then
5880 return Denotes_Same_Object (A1, Prefix (A2))
5881 or else Denotes_Same_Prefix (A1, Prefix (A2));
5882 else
5883 return False;
5884 end if;
5885
5886 elsif Is_Entity_Name (A2) then
5887 return Denotes_Same_Prefix (A1 => A2, A2 => A1);
5888
5889 elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
5890 and then
5891 Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
5892 then
5893 declare
5894 Root1, Root2 : Node_Id;
5895 Depth1, Depth2 : Nat := 0;
5896
5897 begin
5898 Root1 := Prefix (A1);
5899 while not Is_Entity_Name (Root1) loop
5900 if not Nkind_In
5901 (Root1, N_Selected_Component, N_Indexed_Component)
5902 then
5903 return False;
5904 else
5905 Root1 := Prefix (Root1);
5906 end if;
5907
5908 Depth1 := Depth1 + 1;
5909 end loop;
5910
5911 Root2 := Prefix (A2);
5912 while not Is_Entity_Name (Root2) loop
5913 if not Nkind_In (Root2, N_Selected_Component,
5914 N_Indexed_Component)
5915 then
5916 return False;
5917 else
5918 Root2 := Prefix (Root2);
5919 end if;
5920
5921 Depth2 := Depth2 + 1;
5922 end loop;
5923
5924 -- If both have the same depth and they do not denote the same
5925 -- object, they are disjoint and no warning is needed.
5926
5927 if Depth1 = Depth2 then
5928 return False;
5929
5930 elsif Depth1 > Depth2 then
5931 Root1 := Prefix (A1);
5932 for J in 1 .. Depth1 - Depth2 - 1 loop
5933 Root1 := Prefix (Root1);
5934 end loop;
5935
5936 return Denotes_Same_Object (Root1, A2);
5937
5938 else
5939 Root2 := Prefix (A2);
5940 for J in 1 .. Depth2 - Depth1 - 1 loop
5941 Root2 := Prefix (Root2);
5942 end loop;
5943
5944 return Denotes_Same_Object (A1, Root2);
5945 end if;
5946 end;
5947
5948 else
5949 return False;
5950 end if;
5951 end Denotes_Same_Prefix;
5952
5953 ----------------------
5954 -- Denotes_Variable --
5955 ----------------------
5956
5957 function Denotes_Variable (N : Node_Id) return Boolean is
5958 begin
5959 return Is_Variable (N) and then Paren_Count (N) = 0;
5960 end Denotes_Variable;
5961
5962 -----------------------------
5963 -- Depends_On_Discriminant --
5964 -----------------------------
5965
5966 function Depends_On_Discriminant (N : Node_Id) return Boolean is
5967 L : Node_Id;
5968 H : Node_Id;
5969
5970 begin
5971 Get_Index_Bounds (N, L, H);
5972 return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
5973 end Depends_On_Discriminant;
5974
5975 -------------------------
5976 -- Designate_Same_Unit --
5977 -------------------------
5978
5979 function Designate_Same_Unit
5980 (Name1 : Node_Id;
5981 Name2 : Node_Id) return Boolean
5982 is
5983 K1 : constant Node_Kind := Nkind (Name1);
5984 K2 : constant Node_Kind := Nkind (Name2);
5985
5986 function Prefix_Node (N : Node_Id) return Node_Id;
5987 -- Returns the parent unit name node of a defining program unit name
5988 -- or the prefix if N is a selected component or an expanded name.
5989
5990 function Select_Node (N : Node_Id) return Node_Id;
5991 -- Returns the defining identifier node of a defining program unit
5992 -- name or the selector node if N is a selected component or an
5993 -- expanded name.
5994
5995 -----------------
5996 -- Prefix_Node --
5997 -----------------
5998
5999 function Prefix_Node (N : Node_Id) return Node_Id is
6000 begin
6001 if Nkind (N) = N_Defining_Program_Unit_Name then
6002 return Name (N);
6003 else
6004 return Prefix (N);
6005 end if;
6006 end Prefix_Node;
6007
6008 -----------------
6009 -- Select_Node --
6010 -----------------
6011
6012 function Select_Node (N : Node_Id) return Node_Id is
6013 begin
6014 if Nkind (N) = N_Defining_Program_Unit_Name then
6015 return Defining_Identifier (N);
6016 else
6017 return Selector_Name (N);
6018 end if;
6019 end Select_Node;
6020
6021 -- Start of processing for Designate_Same_Unit
6022
6023 begin
6024 if Nkind_In (K1, N_Identifier, N_Defining_Identifier)
6025 and then
6026 Nkind_In (K2, N_Identifier, N_Defining_Identifier)
6027 then
6028 return Chars (Name1) = Chars (Name2);
6029
6030 elsif Nkind_In (K1, N_Expanded_Name,
6031 N_Selected_Component,
6032 N_Defining_Program_Unit_Name)
6033 and then
6034 Nkind_In (K2, N_Expanded_Name,
6035 N_Selected_Component,
6036 N_Defining_Program_Unit_Name)
6037 then
6038 return
6039 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
6040 and then
6041 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
6042
6043 else
6044 return False;
6045 end if;
6046 end Designate_Same_Unit;
6047
6048 ------------------------------------------
6049 -- function Dynamic_Accessibility_Level --
6050 ------------------------------------------
6051
6052 function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
6053 E : Entity_Id;
6054 Loc : constant Source_Ptr := Sloc (Expr);
6055
6056 function Make_Level_Literal (Level : Uint) return Node_Id;
6057 -- Construct an integer literal representing an accessibility level
6058 -- with its type set to Natural.
6059
6060 ------------------------
6061 -- Make_Level_Literal --
6062 ------------------------
6063
6064 function Make_Level_Literal (Level : Uint) return Node_Id is
6065 Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
6066 begin
6067 Set_Etype (Result, Standard_Natural);
6068 return Result;
6069 end Make_Level_Literal;
6070
6071 -- Start of processing for Dynamic_Accessibility_Level
6072
6073 begin
6074 if Is_Entity_Name (Expr) then
6075 E := Entity (Expr);
6076
6077 if Present (Renamed_Object (E)) then
6078 return Dynamic_Accessibility_Level (Renamed_Object (E));
6079 end if;
6080
6081 if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
6082 if Present (Extra_Accessibility (E)) then
6083 return New_Occurrence_Of (Extra_Accessibility (E), Loc);
6084 end if;
6085 end if;
6086 end if;
6087
6088 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
6089
6090 case Nkind (Expr) is
6091
6092 -- For access discriminant, the level of the enclosing object
6093
6094 when N_Selected_Component =>
6095 if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
6096 and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
6097 E_Anonymous_Access_Type
6098 then
6099 return Make_Level_Literal (Object_Access_Level (Expr));
6100 end if;
6101
6102 when N_Attribute_Reference =>
6103 case Get_Attribute_Id (Attribute_Name (Expr)) is
6104
6105 -- For X'Access, the level of the prefix X
6106
6107 when Attribute_Access =>
6108 return Make_Level_Literal
6109 (Object_Access_Level (Prefix (Expr)));
6110
6111 -- Treat the unchecked attributes as library-level
6112
6113 when Attribute_Unchecked_Access |
6114 Attribute_Unrestricted_Access =>
6115 return Make_Level_Literal (Scope_Depth (Standard_Standard));
6116
6117 -- No other access-valued attributes
6118
6119 when others =>
6120 raise Program_Error;
6121 end case;
6122
6123 when N_Allocator =>
6124
6125 -- Unimplemented: depends on context. As an actual parameter where
6126 -- formal type is anonymous, use
6127 -- Scope_Depth (Current_Scope) + 1.
6128 -- For other cases, see 3.10.2(14/3) and following. ???
6129
6130 null;
6131
6132 when N_Type_Conversion =>
6133 if not Is_Local_Anonymous_Access (Etype (Expr)) then
6134
6135 -- Handle type conversions introduced for a rename of an
6136 -- Ada 2012 stand-alone object of an anonymous access type.
6137
6138 return Dynamic_Accessibility_Level (Expression (Expr));
6139 end if;
6140
6141 when others =>
6142 null;
6143 end case;
6144
6145 return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
6146 end Dynamic_Accessibility_Level;
6147
6148 -----------------------------------
6149 -- Effective_Extra_Accessibility --
6150 -----------------------------------
6151
6152 function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
6153 begin
6154 if Present (Renamed_Object (Id))
6155 and then Is_Entity_Name (Renamed_Object (Id))
6156 then
6157 return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
6158 else
6159 return Extra_Accessibility (Id);
6160 end if;
6161 end Effective_Extra_Accessibility;
6162
6163 -----------------------------
6164 -- Effective_Reads_Enabled --
6165 -----------------------------
6166
6167 function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is
6168 begin
6169 return Has_Enabled_Property (Id, Name_Effective_Reads);
6170 end Effective_Reads_Enabled;
6171
6172 ------------------------------
6173 -- Effective_Writes_Enabled --
6174 ------------------------------
6175
6176 function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is
6177 begin
6178 return Has_Enabled_Property (Id, Name_Effective_Writes);
6179 end Effective_Writes_Enabled;
6180
6181 ------------------------------
6182 -- Enclosing_Comp_Unit_Node --
6183 ------------------------------
6184
6185 function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
6186 Current_Node : Node_Id;
6187
6188 begin
6189 Current_Node := N;
6190 while Present (Current_Node)
6191 and then Nkind (Current_Node) /= N_Compilation_Unit
6192 loop
6193 Current_Node := Parent (Current_Node);
6194 end loop;
6195
6196 if Nkind (Current_Node) /= N_Compilation_Unit then
6197 return Empty;
6198 else
6199 return Current_Node;
6200 end if;
6201 end Enclosing_Comp_Unit_Node;
6202
6203 --------------------------
6204 -- Enclosing_CPP_Parent --
6205 --------------------------
6206
6207 function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
6208 Parent_Typ : Entity_Id := Typ;
6209
6210 begin
6211 while not Is_CPP_Class (Parent_Typ)
6212 and then Etype (Parent_Typ) /= Parent_Typ
6213 loop
6214 Parent_Typ := Etype (Parent_Typ);
6215
6216 if Is_Private_Type (Parent_Typ) then
6217 Parent_Typ := Full_View (Base_Type (Parent_Typ));
6218 end if;
6219 end loop;
6220
6221 pragma Assert (Is_CPP_Class (Parent_Typ));
6222 return Parent_Typ;
6223 end Enclosing_CPP_Parent;
6224
6225 ---------------------------
6226 -- Enclosing_Declaration --
6227 ---------------------------
6228
6229 function Enclosing_Declaration (N : Node_Id) return Node_Id is
6230 Decl : Node_Id := N;
6231
6232 begin
6233 while Present (Decl)
6234 and then not (Nkind (Decl) in N_Declaration
6235 or else
6236 Nkind (Decl) in N_Later_Decl_Item)
6237 loop
6238 Decl := Parent (Decl);
6239 end loop;
6240
6241 return Decl;
6242 end Enclosing_Declaration;
6243
6244 ----------------------------
6245 -- Enclosing_Generic_Body --
6246 ----------------------------
6247
6248 function Enclosing_Generic_Body
6249 (N : Node_Id) return Node_Id
6250 is
6251 P : Node_Id;
6252 Decl : Node_Id;
6253 Spec : Node_Id;
6254
6255 begin
6256 P := Parent (N);
6257 while Present (P) loop
6258 if Nkind (P) = N_Package_Body
6259 or else Nkind (P) = N_Subprogram_Body
6260 then
6261 Spec := Corresponding_Spec (P);
6262
6263 if Present (Spec) then
6264 Decl := Unit_Declaration_Node (Spec);
6265
6266 if Nkind (Decl) = N_Generic_Package_Declaration
6267 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
6268 then
6269 return P;
6270 end if;
6271 end if;
6272 end if;
6273
6274 P := Parent (P);
6275 end loop;
6276
6277 return Empty;
6278 end Enclosing_Generic_Body;
6279
6280 ----------------------------
6281 -- Enclosing_Generic_Unit --
6282 ----------------------------
6283
6284 function Enclosing_Generic_Unit
6285 (N : Node_Id) return Node_Id
6286 is
6287 P : Node_Id;
6288 Decl : Node_Id;
6289 Spec : Node_Id;
6290
6291 begin
6292 P := Parent (N);
6293 while Present (P) loop
6294 if Nkind (P) = N_Generic_Package_Declaration
6295 or else Nkind (P) = N_Generic_Subprogram_Declaration
6296 then
6297 return P;
6298
6299 elsif Nkind (P) = N_Package_Body
6300 or else Nkind (P) = N_Subprogram_Body
6301 then
6302 Spec := Corresponding_Spec (P);
6303
6304 if Present (Spec) then
6305 Decl := Unit_Declaration_Node (Spec);
6306
6307 if Nkind (Decl) = N_Generic_Package_Declaration
6308 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
6309 then
6310 return Decl;
6311 end if;
6312 end if;
6313 end if;
6314
6315 P := Parent (P);
6316 end loop;
6317
6318 return Empty;
6319 end Enclosing_Generic_Unit;
6320
6321 -------------------------------
6322 -- Enclosing_Lib_Unit_Entity --
6323 -------------------------------
6324
6325 function Enclosing_Lib_Unit_Entity
6326 (E : Entity_Id := Current_Scope) return Entity_Id
6327 is
6328 Unit_Entity : Entity_Id;
6329
6330 begin
6331 -- Look for enclosing library unit entity by following scope links.
6332 -- Equivalent to, but faster than indexing through the scope stack.
6333
6334 Unit_Entity := E;
6335 while (Present (Scope (Unit_Entity))
6336 and then Scope (Unit_Entity) /= Standard_Standard)
6337 and not Is_Child_Unit (Unit_Entity)
6338 loop
6339 Unit_Entity := Scope (Unit_Entity);
6340 end loop;
6341
6342 return Unit_Entity;
6343 end Enclosing_Lib_Unit_Entity;
6344
6345 -----------------------------
6346 -- Enclosing_Lib_Unit_Node --
6347 -----------------------------
6348
6349 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
6350 Encl_Unit : Node_Id;
6351
6352 begin
6353 Encl_Unit := Enclosing_Comp_Unit_Node (N);
6354 while Present (Encl_Unit)
6355 and then Nkind (Unit (Encl_Unit)) = N_Subunit
6356 loop
6357 Encl_Unit := Library_Unit (Encl_Unit);
6358 end loop;
6359
6360 pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit);
6361 return Encl_Unit;
6362 end Enclosing_Lib_Unit_Node;
6363
6364 -----------------------
6365 -- Enclosing_Package --
6366 -----------------------
6367
6368 function Enclosing_Package (E : Entity_Id) return Entity_Id is
6369 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
6370
6371 begin
6372 if Dynamic_Scope = Standard_Standard then
6373 return Standard_Standard;
6374
6375 elsif Dynamic_Scope = Empty then
6376 return Empty;
6377
6378 elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
6379 E_Generic_Package)
6380 then
6381 return Dynamic_Scope;
6382
6383 else
6384 return Enclosing_Package (Dynamic_Scope);
6385 end if;
6386 end Enclosing_Package;
6387
6388 -------------------------------------
6389 -- Enclosing_Package_Or_Subprogram --
6390 -------------------------------------
6391
6392 function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is
6393 S : Entity_Id;
6394
6395 begin
6396 S := Scope (E);
6397 while Present (S) loop
6398 if Is_Package_Or_Generic_Package (S)
6399 or else Ekind (S) = E_Package_Body
6400 then
6401 return S;
6402
6403 elsif Is_Subprogram_Or_Generic_Subprogram (S)
6404 or else Ekind (S) = E_Subprogram_Body
6405 then
6406 return S;
6407
6408 else
6409 S := Scope (S);
6410 end if;
6411 end loop;
6412
6413 return Empty;
6414 end Enclosing_Package_Or_Subprogram;
6415
6416 --------------------------
6417 -- Enclosing_Subprogram --
6418 --------------------------
6419
6420 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
6421 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
6422
6423 begin
6424 if Dynamic_Scope = Standard_Standard then
6425 return Empty;
6426
6427 elsif Dynamic_Scope = Empty then
6428 return Empty;
6429
6430 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
6431 return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
6432
6433 elsif Ekind (Dynamic_Scope) = E_Block
6434 or else Ekind (Dynamic_Scope) = E_Return_Statement
6435 then
6436 return Enclosing_Subprogram (Dynamic_Scope);
6437
6438 elsif Ekind (Dynamic_Scope) = E_Task_Type then
6439 return Get_Task_Body_Procedure (Dynamic_Scope);
6440
6441 elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
6442 and then Present (Full_View (Dynamic_Scope))
6443 and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
6444 then
6445 return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
6446
6447 -- No body is generated if the protected operation is eliminated
6448
6449 elsif Convention (Dynamic_Scope) = Convention_Protected
6450 and then not Is_Eliminated (Dynamic_Scope)
6451 and then Present (Protected_Body_Subprogram (Dynamic_Scope))
6452 then
6453 return Protected_Body_Subprogram (Dynamic_Scope);
6454
6455 else
6456 return Dynamic_Scope;
6457 end if;
6458 end Enclosing_Subprogram;
6459
6460 ------------------------
6461 -- Ensure_Freeze_Node --
6462 ------------------------
6463
6464 procedure Ensure_Freeze_Node (E : Entity_Id) is
6465 FN : Node_Id;
6466 begin
6467 if No (Freeze_Node (E)) then
6468 FN := Make_Freeze_Entity (Sloc (E));
6469 Set_Has_Delayed_Freeze (E);
6470 Set_Freeze_Node (E, FN);
6471 Set_Access_Types_To_Process (FN, No_Elist);
6472 Set_TSS_Elist (FN, No_Elist);
6473 Set_Entity (FN, E);
6474 end if;
6475 end Ensure_Freeze_Node;
6476
6477 ----------------
6478 -- Enter_Name --
6479 ----------------
6480
6481 procedure Enter_Name (Def_Id : Entity_Id) is
6482 C : constant Entity_Id := Current_Entity (Def_Id);
6483 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
6484 S : constant Entity_Id := Current_Scope;
6485
6486 begin
6487 Generate_Definition (Def_Id);
6488
6489 -- Add new name to current scope declarations. Check for duplicate
6490 -- declaration, which may or may not be a genuine error.
6491
6492 if Present (E) then
6493
6494 -- Case of previous entity entered because of a missing declaration
6495 -- or else a bad subtype indication. Best is to use the new entity,
6496 -- and make the previous one invisible.
6497
6498 if Etype (E) = Any_Type then
6499 Set_Is_Immediately_Visible (E, False);
6500
6501 -- Case of renaming declaration constructed for package instances.
6502 -- if there is an explicit declaration with the same identifier,
6503 -- the renaming is not immediately visible any longer, but remains
6504 -- visible through selected component notation.
6505
6506 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
6507 and then not Comes_From_Source (E)
6508 then
6509 Set_Is_Immediately_Visible (E, False);
6510
6511 -- The new entity may be the package renaming, which has the same
6512 -- same name as a generic formal which has been seen already.
6513
6514 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
6515 and then not Comes_From_Source (Def_Id)
6516 then
6517 Set_Is_Immediately_Visible (E, False);
6518
6519 -- For a fat pointer corresponding to a remote access to subprogram,
6520 -- we use the same identifier as the RAS type, so that the proper
6521 -- name appears in the stub. This type is only retrieved through
6522 -- the RAS type and never by visibility, and is not added to the
6523 -- visibility list (see below).
6524
6525 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
6526 and then Ekind (Def_Id) = E_Record_Type
6527 and then Present (Corresponding_Remote_Type (Def_Id))
6528 then
6529 null;
6530
6531 -- Case of an implicit operation or derived literal. The new entity
6532 -- hides the implicit one, which is removed from all visibility,
6533 -- i.e. the entity list of its scope, and homonym chain of its name.
6534
6535 elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
6536 or else Is_Internal (E)
6537 then
6538 declare
6539 Decl : constant Node_Id := Parent (E);
6540 Prev : Entity_Id;
6541 Prev_Vis : Entity_Id;
6542
6543 begin
6544 -- If E is an implicit declaration, it cannot be the first
6545 -- entity in the scope.
6546
6547 Prev := First_Entity (Current_Scope);
6548 while Present (Prev) and then Next_Entity (Prev) /= E loop
6549 Next_Entity (Prev);
6550 end loop;
6551
6552 if No (Prev) then
6553
6554 -- If E is not on the entity chain of the current scope,
6555 -- it is an implicit declaration in the generic formal
6556 -- part of a generic subprogram. When analyzing the body,
6557 -- the generic formals are visible but not on the entity
6558 -- chain of the subprogram. The new entity will become
6559 -- the visible one in the body.
6560
6561 pragma Assert
6562 (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
6563 null;
6564
6565 else
6566 Set_Next_Entity (Prev, Next_Entity (E));
6567
6568 if No (Next_Entity (Prev)) then
6569 Set_Last_Entity (Current_Scope, Prev);
6570 end if;
6571
6572 if E = Current_Entity (E) then
6573 Prev_Vis := Empty;
6574
6575 else
6576 Prev_Vis := Current_Entity (E);
6577 while Homonym (Prev_Vis) /= E loop
6578 Prev_Vis := Homonym (Prev_Vis);
6579 end loop;
6580 end if;
6581
6582 if Present (Prev_Vis) then
6583
6584 -- Skip E in the visibility chain
6585
6586 Set_Homonym (Prev_Vis, Homonym (E));
6587
6588 else
6589 Set_Name_Entity_Id (Chars (E), Homonym (E));
6590 end if;
6591 end if;
6592 end;
6593
6594 -- This section of code could use a comment ???
6595
6596 elsif Present (Etype (E))
6597 and then Is_Concurrent_Type (Etype (E))
6598 and then E = Def_Id
6599 then
6600 return;
6601
6602 -- If the homograph is a protected component renaming, it should not
6603 -- be hiding the current entity. Such renamings are treated as weak
6604 -- declarations.
6605
6606 elsif Is_Prival (E) then
6607 Set_Is_Immediately_Visible (E, False);
6608
6609 -- In this case the current entity is a protected component renaming.
6610 -- Perform minimal decoration by setting the scope and return since
6611 -- the prival should not be hiding other visible entities.
6612
6613 elsif Is_Prival (Def_Id) then
6614 Set_Scope (Def_Id, Current_Scope);
6615 return;
6616
6617 -- Analogous to privals, the discriminal generated for an entry index
6618 -- parameter acts as a weak declaration. Perform minimal decoration
6619 -- to avoid bogus errors.
6620
6621 elsif Is_Discriminal (Def_Id)
6622 and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
6623 then
6624 Set_Scope (Def_Id, Current_Scope);
6625 return;
6626
6627 -- In the body or private part of an instance, a type extension may
6628 -- introduce a component with the same name as that of an actual. The
6629 -- legality rule is not enforced, but the semantics of the full type
6630 -- with two components of same name are not clear at this point???
6631
6632 elsif In_Instance_Not_Visible then
6633 null;
6634
6635 -- When compiling a package body, some child units may have become
6636 -- visible. They cannot conflict with local entities that hide them.
6637
6638 elsif Is_Child_Unit (E)
6639 and then In_Open_Scopes (Scope (E))
6640 and then not Is_Immediately_Visible (E)
6641 then
6642 null;
6643
6644 -- Conversely, with front-end inlining we may compile the parent body
6645 -- first, and a child unit subsequently. The context is now the
6646 -- parent spec, and body entities are not visible.
6647
6648 elsif Is_Child_Unit (Def_Id)
6649 and then Is_Package_Body_Entity (E)
6650 and then not In_Package_Body (Current_Scope)
6651 then
6652 null;
6653
6654 -- Case of genuine duplicate declaration
6655
6656 else
6657 Error_Msg_Sloc := Sloc (E);
6658
6659 -- If the previous declaration is an incomplete type declaration
6660 -- this may be an attempt to complete it with a private type. The
6661 -- following avoids confusing cascaded errors.
6662
6663 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
6664 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
6665 then
6666 Error_Msg_N
6667 ("incomplete type cannot be completed with a private " &
6668 "declaration", Parent (Def_Id));
6669 Set_Is_Immediately_Visible (E, False);
6670 Set_Full_View (E, Def_Id);
6671
6672 -- An inherited component of a record conflicts with a new
6673 -- discriminant. The discriminant is inserted first in the scope,
6674 -- but the error should be posted on it, not on the component.
6675
6676 elsif Ekind (E) = E_Discriminant
6677 and then Present (Scope (Def_Id))
6678 and then Scope (Def_Id) /= Current_Scope
6679 then
6680 Error_Msg_Sloc := Sloc (Def_Id);
6681 Error_Msg_N ("& conflicts with declaration#", E);
6682 return;
6683
6684 -- If the name of the unit appears in its own context clause, a
6685 -- dummy package with the name has already been created, and the
6686 -- error emitted. Try to continue quietly.
6687
6688 elsif Error_Posted (E)
6689 and then Sloc (E) = No_Location
6690 and then Nkind (Parent (E)) = N_Package_Specification
6691 and then Current_Scope = Standard_Standard
6692 then
6693 Set_Scope (Def_Id, Current_Scope);
6694 return;
6695
6696 else
6697 Error_Msg_N ("& conflicts with declaration#", Def_Id);
6698
6699 -- Avoid cascaded messages with duplicate components in
6700 -- derived types.
6701
6702 if Ekind_In (E, E_Component, E_Discriminant) then
6703 return;
6704 end if;
6705 end if;
6706
6707 if Nkind (Parent (Parent (Def_Id))) =
6708 N_Generic_Subprogram_Declaration
6709 and then Def_Id =
6710 Defining_Entity (Specification (Parent (Parent (Def_Id))))
6711 then
6712 Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
6713 end if;
6714
6715 -- If entity is in standard, then we are in trouble, because it
6716 -- means that we have a library package with a duplicated name.
6717 -- That's hard to recover from, so abort.
6718
6719 if S = Standard_Standard then
6720 raise Unrecoverable_Error;
6721
6722 -- Otherwise we continue with the declaration. Having two
6723 -- identical declarations should not cause us too much trouble.
6724
6725 else
6726 null;
6727 end if;
6728 end if;
6729 end if;
6730
6731 -- If we fall through, declaration is OK, at least OK enough to continue
6732
6733 -- If Def_Id is a discriminant or a record component we are in the midst
6734 -- of inheriting components in a derived record definition. Preserve
6735 -- their Ekind and Etype.
6736
6737 if Ekind_In (Def_Id, E_Discriminant, E_Component) then
6738 null;
6739
6740 -- If a type is already set, leave it alone (happens when a type
6741 -- declaration is reanalyzed following a call to the optimizer).
6742
6743 elsif Present (Etype (Def_Id)) then
6744 null;
6745
6746 -- Otherwise, the kind E_Void insures that premature uses of the entity
6747 -- will be detected. Any_Type insures that no cascaded errors will occur
6748
6749 else
6750 Set_Ekind (Def_Id, E_Void);
6751 Set_Etype (Def_Id, Any_Type);
6752 end if;
6753
6754 -- Inherited discriminants and components in derived record types are
6755 -- immediately visible. Itypes are not.
6756
6757 -- Unless the Itype is for a record type with a corresponding remote
6758 -- type (what is that about, it was not commented ???)
6759
6760 if Ekind_In (Def_Id, E_Discriminant, E_Component)
6761 or else
6762 ((not Is_Record_Type (Def_Id)
6763 or else No (Corresponding_Remote_Type (Def_Id)))
6764 and then not Is_Itype (Def_Id))
6765 then
6766 Set_Is_Immediately_Visible (Def_Id);
6767 Set_Current_Entity (Def_Id);
6768 end if;
6769
6770 Set_Homonym (Def_Id, C);
6771 Append_Entity (Def_Id, S);
6772 Set_Public_Status (Def_Id);
6773
6774 -- Declaring a homonym is not allowed in SPARK ...
6775
6776 if Present (C) and then Restriction_Check_Required (SPARK_05) then
6777 declare
6778 Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
6779 Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
6780 Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C);
6781
6782 begin
6783 -- ... unless the new declaration is in a subprogram, and the
6784 -- visible declaration is a variable declaration or a parameter
6785 -- specification outside that subprogram.
6786
6787 if Present (Enclosing_Subp)
6788 and then Nkind_In (Parent (C), N_Object_Declaration,
6789 N_Parameter_Specification)
6790 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
6791 then
6792 null;
6793
6794 -- ... or the new declaration is in a package, and the visible
6795 -- declaration occurs outside that package.
6796
6797 elsif Present (Enclosing_Pack)
6798 and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
6799 then
6800 null;
6801
6802 -- ... or the new declaration is a component declaration in a
6803 -- record type definition.
6804
6805 elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
6806 null;
6807
6808 -- Don't issue error for non-source entities
6809
6810 elsif Comes_From_Source (Def_Id)
6811 and then Comes_From_Source (C)
6812 then
6813 Error_Msg_Sloc := Sloc (C);
6814 Check_SPARK_05_Restriction
6815 ("redeclaration of identifier &#", Def_Id);
6816 end if;
6817 end;
6818 end if;
6819
6820 -- Warn if new entity hides an old one
6821
6822 if Warn_On_Hiding and then Present (C)
6823
6824 -- Don't warn for record components since they always have a well
6825 -- defined scope which does not confuse other uses. Note that in
6826 -- some cases, Ekind has not been set yet.
6827
6828 and then Ekind (C) /= E_Component
6829 and then Ekind (C) /= E_Discriminant
6830 and then Nkind (Parent (C)) /= N_Component_Declaration
6831 and then Ekind (Def_Id) /= E_Component
6832 and then Ekind (Def_Id) /= E_Discriminant
6833 and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
6834
6835 -- Don't warn for one character variables. It is too common to use
6836 -- such variables as locals and will just cause too many false hits.
6837
6838 and then Length_Of_Name (Chars (C)) /= 1
6839
6840 -- Don't warn for non-source entities
6841
6842 and then Comes_From_Source (C)
6843 and then Comes_From_Source (Def_Id)
6844
6845 -- Don't warn unless entity in question is in extended main source
6846
6847 and then In_Extended_Main_Source_Unit (Def_Id)
6848
6849 -- Finally, the hidden entity must be either immediately visible or
6850 -- use visible (i.e. from a used package).
6851
6852 and then
6853 (Is_Immediately_Visible (C)
6854 or else
6855 Is_Potentially_Use_Visible (C))
6856 then
6857 Error_Msg_Sloc := Sloc (C);
6858 Error_Msg_N ("declaration hides &#?h?", Def_Id);
6859 end if;
6860 end Enter_Name;
6861
6862 ---------------
6863 -- Entity_Of --
6864 ---------------
6865
6866 function Entity_Of (N : Node_Id) return Entity_Id is
6867 Id : Entity_Id;
6868
6869 begin
6870 Id := Empty;
6871
6872 if Is_Entity_Name (N) then
6873 Id := Entity (N);
6874
6875 -- Follow a possible chain of renamings to reach the root renamed
6876 -- object.
6877
6878 while Present (Id)
6879 and then Is_Object (Id)
6880 and then Present (Renamed_Object (Id))
6881 loop
6882 if Is_Entity_Name (Renamed_Object (Id)) then
6883 Id := Entity (Renamed_Object (Id));
6884 else
6885 Id := Empty;
6886 exit;
6887 end if;
6888 end loop;
6889 end if;
6890
6891 return Id;
6892 end Entity_Of;
6893
6894 --------------------------
6895 -- Explain_Limited_Type --
6896 --------------------------
6897
6898 procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
6899 C : Entity_Id;
6900
6901 begin
6902 -- For array, component type must be limited
6903
6904 if Is_Array_Type (T) then
6905 Error_Msg_Node_2 := T;
6906 Error_Msg_NE
6907 ("\component type& of type& is limited", N, Component_Type (T));
6908 Explain_Limited_Type (Component_Type (T), N);
6909
6910 elsif Is_Record_Type (T) then
6911
6912 -- No need for extra messages if explicit limited record
6913
6914 if Is_Limited_Record (Base_Type (T)) then
6915 return;
6916 end if;
6917
6918 -- Otherwise find a limited component. Check only components that
6919 -- come from source, or inherited components that appear in the
6920 -- source of the ancestor.
6921
6922 C := First_Component (T);
6923 while Present (C) loop
6924 if Is_Limited_Type (Etype (C))
6925 and then
6926 (Comes_From_Source (C)
6927 or else
6928 (Present (Original_Record_Component (C))
6929 and then
6930 Comes_From_Source (Original_Record_Component (C))))
6931 then
6932 Error_Msg_Node_2 := T;
6933 Error_Msg_NE ("\component& of type& has limited type", N, C);
6934 Explain_Limited_Type (Etype (C), N);
6935 return;
6936 end if;
6937
6938 Next_Component (C);
6939 end loop;
6940
6941 -- The type may be declared explicitly limited, even if no component
6942 -- of it is limited, in which case we fall out of the loop.
6943 return;
6944 end if;
6945 end Explain_Limited_Type;
6946
6947 -------------------------------
6948 -- Extensions_Visible_Status --
6949 -------------------------------
6950
6951 function Extensions_Visible_Status
6952 (Id : Entity_Id) return Extensions_Visible_Mode
6953 is
6954 Arg : Node_Id;
6955 Decl : Node_Id;
6956 Expr : Node_Id;
6957 Prag : Node_Id;
6958 Subp : Entity_Id;
6959
6960 begin
6961 -- When a formal parameter is subject to Extensions_Visible, the pragma
6962 -- is stored in the contract of related subprogram.
6963
6964 if Is_Formal (Id) then
6965 Subp := Scope (Id);
6966
6967 elsif Is_Subprogram_Or_Generic_Subprogram (Id) then
6968 Subp := Id;
6969
6970 -- No other construct carries this pragma
6971
6972 else
6973 return Extensions_Visible_None;
6974 end if;
6975
6976 Prag := Get_Pragma (Subp, Pragma_Extensions_Visible);
6977
6978 -- In certain cases analysis may request the Extensions_Visible status
6979 -- of an expression function before the pragma has been analyzed yet.
6980 -- Inspect the declarative items after the expression function looking
6981 -- for the pragma (if any).
6982
6983 if No (Prag) and then Is_Expression_Function (Subp) then
6984 Decl := Next (Unit_Declaration_Node (Subp));
6985 while Present (Decl) loop
6986 if Nkind (Decl) = N_Pragma
6987 and then Pragma_Name (Decl) = Name_Extensions_Visible
6988 then
6989 Prag := Decl;
6990 exit;
6991
6992 -- A source construct ends the region where Extensions_Visible may
6993 -- appear, stop the traversal. An expanded expression function is
6994 -- no longer a source construct, but it must still be recognized.
6995
6996 elsif Comes_From_Source (Decl)
6997 or else
6998 (Nkind_In (Decl, N_Subprogram_Body,
6999 N_Subprogram_Declaration)
7000 and then Is_Expression_Function (Defining_Entity (Decl)))
7001 then
7002 exit;
7003 end if;
7004
7005 Next (Decl);
7006 end loop;
7007 end if;
7008
7009 -- Extract the value from the Boolean expression (if any)
7010
7011 if Present (Prag) then
7012 Arg := First (Pragma_Argument_Associations (Prag));
7013
7014 if Present (Arg) then
7015 Expr := Get_Pragma_Arg (Arg);
7016
7017 -- When the associated subprogram is an expression function, the
7018 -- argument of the pragma may not have been analyzed.
7019
7020 if not Analyzed (Expr) then
7021 Preanalyze_And_Resolve (Expr, Standard_Boolean);
7022 end if;
7023
7024 -- Guard against cascading errors when the argument of pragma
7025 -- Extensions_Visible is not a valid static Boolean expression.
7026
7027 if Error_Posted (Expr) then
7028 return Extensions_Visible_None;
7029
7030 elsif Is_True (Expr_Value (Expr)) then
7031 return Extensions_Visible_True;
7032
7033 else
7034 return Extensions_Visible_False;
7035 end if;
7036
7037 -- Otherwise the aspect or pragma defaults to True
7038
7039 else
7040 return Extensions_Visible_True;
7041 end if;
7042
7043 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
7044 -- directly specified. In SPARK code, its value defaults to "False".
7045
7046 elsif SPARK_Mode = On then
7047 return Extensions_Visible_False;
7048
7049 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
7050 -- "True".
7051
7052 else
7053 return Extensions_Visible_True;
7054 end if;
7055 end Extensions_Visible_Status;
7056
7057 -----------------
7058 -- Find_Actual --
7059 -----------------
7060
7061 procedure Find_Actual
7062 (N : Node_Id;
7063 Formal : out Entity_Id;
7064 Call : out Node_Id)
7065 is
7066 Context : constant Node_Id := Parent (N);
7067 Actual : Node_Id;
7068 Call_Nam : Node_Id;
7069
7070 begin
7071 if Nkind_In (Context, N_Indexed_Component, N_Selected_Component)
7072 and then N = Prefix (Context)
7073 then
7074 Find_Actual (Context, Formal, Call);
7075 return;
7076
7077 elsif Nkind (Context) = N_Parameter_Association
7078 and then N = Explicit_Actual_Parameter (Context)
7079 then
7080 Call := Parent (Context);
7081
7082 elsif Nkind_In (Context, N_Entry_Call_Statement,
7083 N_Function_Call,
7084 N_Procedure_Call_Statement)
7085 then
7086 Call := Context;
7087
7088 else
7089 Formal := Empty;
7090 Call := Empty;
7091 return;
7092 end if;
7093
7094 -- If we have a call to a subprogram look for the parameter. Note that
7095 -- we exclude overloaded calls, since we don't know enough to be sure
7096 -- of giving the right answer in this case.
7097
7098 if Nkind_In (Call, N_Entry_Call_Statement,
7099 N_Function_Call,
7100 N_Procedure_Call_Statement)
7101 then
7102 Call_Nam := Name (Call);
7103
7104 -- A call to a protected or task entry appears as a selected
7105 -- component rather than an expanded name.
7106
7107 if Nkind (Call_Nam) = N_Selected_Component then
7108 Call_Nam := Selector_Name (Call_Nam);
7109 end if;
7110
7111 if Is_Entity_Name (Call_Nam)
7112 and then Present (Entity (Call_Nam))
7113 and then Is_Overloadable (Entity (Call_Nam))
7114 and then not Is_Overloaded (Call_Nam)
7115 then
7116 -- If node is name in call it is not an actual
7117
7118 if N = Call_Nam then
7119 Formal := Empty;
7120 Call := Empty;
7121 return;
7122 end if;
7123
7124 -- Fall here if we are definitely a parameter
7125
7126 Actual := First_Actual (Call);
7127 Formal := First_Formal (Entity (Call_Nam));
7128 while Present (Formal) and then Present (Actual) loop
7129 if Actual = N then
7130 return;
7131
7132 -- An actual that is the prefix in a prefixed call may have
7133 -- been rewritten in the call, after the deferred reference
7134 -- was collected. Check if sloc and kinds and names match.
7135
7136 elsif Sloc (Actual) = Sloc (N)
7137 and then Nkind (Actual) = N_Identifier
7138 and then Nkind (Actual) = Nkind (N)
7139 and then Chars (Actual) = Chars (N)
7140 then
7141 return;
7142
7143 else
7144 Actual := Next_Actual (Actual);
7145 Formal := Next_Formal (Formal);
7146 end if;
7147 end loop;
7148 end if;
7149 end if;
7150
7151 -- Fall through here if we did not find matching actual
7152
7153 Formal := Empty;
7154 Call := Empty;
7155 end Find_Actual;
7156
7157 ---------------------------
7158 -- Find_Body_Discriminal --
7159 ---------------------------
7160
7161 function Find_Body_Discriminal
7162 (Spec_Discriminant : Entity_Id) return Entity_Id
7163 is
7164 Tsk : Entity_Id;
7165 Disc : Entity_Id;
7166
7167 begin
7168 -- If expansion is suppressed, then the scope can be the concurrent type
7169 -- itself rather than a corresponding concurrent record type.
7170
7171 if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
7172 Tsk := Scope (Spec_Discriminant);
7173
7174 else
7175 pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
7176
7177 Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
7178 end if;
7179
7180 -- Find discriminant of original concurrent type, and use its current
7181 -- discriminal, which is the renaming within the task/protected body.
7182
7183 Disc := First_Discriminant (Tsk);
7184 while Present (Disc) loop
7185 if Chars (Disc) = Chars (Spec_Discriminant) then
7186 return Discriminal (Disc);
7187 end if;
7188
7189 Next_Discriminant (Disc);
7190 end loop;
7191
7192 -- That loop should always succeed in finding a matching entry and
7193 -- returning. Fatal error if not.
7194
7195 raise Program_Error;
7196 end Find_Body_Discriminal;
7197
7198 -------------------------------------
7199 -- Find_Corresponding_Discriminant --
7200 -------------------------------------
7201
7202 function Find_Corresponding_Discriminant
7203 (Id : Node_Id;
7204 Typ : Entity_Id) return Entity_Id
7205 is
7206 Par_Disc : Entity_Id;
7207 Old_Disc : Entity_Id;
7208 New_Disc : Entity_Id;
7209
7210 begin
7211 Par_Disc := Original_Record_Component (Original_Discriminant (Id));
7212
7213 -- The original type may currently be private, and the discriminant
7214 -- only appear on its full view.
7215
7216 if Is_Private_Type (Scope (Par_Disc))
7217 and then not Has_Discriminants (Scope (Par_Disc))
7218 and then Present (Full_View (Scope (Par_Disc)))
7219 then
7220 Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
7221 else
7222 Old_Disc := First_Discriminant (Scope (Par_Disc));
7223 end if;
7224
7225 if Is_Class_Wide_Type (Typ) then
7226 New_Disc := First_Discriminant (Root_Type (Typ));
7227 else
7228 New_Disc := First_Discriminant (Typ);
7229 end if;
7230
7231 while Present (Old_Disc) and then Present (New_Disc) loop
7232 if Old_Disc = Par_Disc then
7233 return New_Disc;
7234 end if;
7235
7236 Next_Discriminant (Old_Disc);
7237 Next_Discriminant (New_Disc);
7238 end loop;
7239
7240 -- Should always find it
7241
7242 raise Program_Error;
7243 end Find_Corresponding_Discriminant;
7244
7245 ----------------------------------
7246 -- Find_Enclosing_Iterator_Loop --
7247 ----------------------------------
7248
7249 function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is
7250 Constr : Node_Id;
7251 S : Entity_Id;
7252
7253 begin
7254 -- Traverse the scope chain looking for an iterator loop. Such loops are
7255 -- usually transformed into blocks, hence the use of Original_Node.
7256
7257 S := Id;
7258 while Present (S) and then S /= Standard_Standard loop
7259 if Ekind (S) = E_Loop
7260 and then Nkind (Parent (S)) = N_Implicit_Label_Declaration
7261 then
7262 Constr := Original_Node (Label_Construct (Parent (S)));
7263
7264 if Nkind (Constr) = N_Loop_Statement
7265 and then Present (Iteration_Scheme (Constr))
7266 and then Nkind (Iterator_Specification
7267 (Iteration_Scheme (Constr))) =
7268 N_Iterator_Specification
7269 then
7270 return S;
7271 end if;
7272 end if;
7273
7274 S := Scope (S);
7275 end loop;
7276
7277 return Empty;
7278 end Find_Enclosing_Iterator_Loop;
7279
7280 ------------------------------------
7281 -- Find_Loop_In_Conditional_Block --
7282 ------------------------------------
7283
7284 function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is
7285 Stmt : Node_Id;
7286
7287 begin
7288 Stmt := N;
7289
7290 if Nkind (Stmt) = N_If_Statement then
7291 Stmt := First (Then_Statements (Stmt));
7292 end if;
7293
7294 pragma Assert (Nkind (Stmt) = N_Block_Statement);
7295
7296 -- Inspect the statements of the conditional block. In general the loop
7297 -- should be the first statement in the statement sequence of the block,
7298 -- but the finalization machinery may have introduced extra object
7299 -- declarations.
7300
7301 Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
7302 while Present (Stmt) loop
7303 if Nkind (Stmt) = N_Loop_Statement then
7304 return Stmt;
7305 end if;
7306
7307 Next (Stmt);
7308 end loop;
7309
7310 -- The expansion of attribute 'Loop_Entry produced a malformed block
7311
7312 raise Program_Error;
7313 end Find_Loop_In_Conditional_Block;
7314
7315 --------------------------
7316 -- Find_Overlaid_Entity --
7317 --------------------------
7318
7319 procedure Find_Overlaid_Entity
7320 (N : Node_Id;
7321 Ent : out Entity_Id;
7322 Off : out Boolean)
7323 is
7324 Expr : Node_Id;
7325
7326 begin
7327 -- We are looking for one of the two following forms:
7328
7329 -- for X'Address use Y'Address
7330
7331 -- or
7332
7333 -- Const : constant Address := expr;
7334 -- ...
7335 -- for X'Address use Const;
7336
7337 -- In the second case, the expr is either Y'Address, or recursively a
7338 -- constant that eventually references Y'Address.
7339
7340 Ent := Empty;
7341 Off := False;
7342
7343 if Nkind (N) = N_Attribute_Definition_Clause
7344 and then Chars (N) = Name_Address
7345 then
7346 Expr := Expression (N);
7347
7348 -- This loop checks the form of the expression for Y'Address,
7349 -- using recursion to deal with intermediate constants.
7350
7351 loop
7352 -- Check for Y'Address
7353
7354 if Nkind (Expr) = N_Attribute_Reference
7355 and then Attribute_Name (Expr) = Name_Address
7356 then
7357 Expr := Prefix (Expr);
7358 exit;
7359
7360 -- Check for Const where Const is a constant entity
7361
7362 elsif Is_Entity_Name (Expr)
7363 and then Ekind (Entity (Expr)) = E_Constant
7364 then
7365 Expr := Constant_Value (Entity (Expr));
7366
7367 -- Anything else does not need checking
7368
7369 else
7370 return;
7371 end if;
7372 end loop;
7373
7374 -- This loop checks the form of the prefix for an entity, using
7375 -- recursion to deal with intermediate components.
7376
7377 loop
7378 -- Check for Y where Y is an entity
7379
7380 if Is_Entity_Name (Expr) then
7381 Ent := Entity (Expr);
7382 return;
7383
7384 -- Check for components
7385
7386 elsif
7387 Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
7388 then
7389 Expr := Prefix (Expr);
7390 Off := True;
7391
7392 -- Anything else does not need checking
7393
7394 else
7395 return;
7396 end if;
7397 end loop;
7398 end if;
7399 end Find_Overlaid_Entity;
7400
7401 -------------------------
7402 -- Find_Parameter_Type --
7403 -------------------------
7404
7405 function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
7406 begin
7407 if Nkind (Param) /= N_Parameter_Specification then
7408 return Empty;
7409
7410 -- For an access parameter, obtain the type from the formal entity
7411 -- itself, because access to subprogram nodes do not carry a type.
7412 -- Shouldn't we always use the formal entity ???
7413
7414 elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
7415 return Etype (Defining_Identifier (Param));
7416
7417 else
7418 return Etype (Parameter_Type (Param));
7419 end if;
7420 end Find_Parameter_Type;
7421
7422 -----------------------------------
7423 -- Find_Placement_In_State_Space --
7424 -----------------------------------
7425
7426 procedure Find_Placement_In_State_Space
7427 (Item_Id : Entity_Id;
7428 Placement : out State_Space_Kind;
7429 Pack_Id : out Entity_Id)
7430 is
7431 Context : Entity_Id;
7432
7433 begin
7434 -- Assume that the item does not appear in the state space of a package
7435
7436 Placement := Not_In_Package;
7437 Pack_Id := Empty;
7438
7439 -- Climb the scope stack and examine the enclosing context
7440
7441 Context := Scope (Item_Id);
7442 while Present (Context) and then Context /= Standard_Standard loop
7443 if Ekind (Context) = E_Package then
7444 Pack_Id := Context;
7445
7446 -- A package body is a cut off point for the traversal as the item
7447 -- cannot be visible to the outside from this point on. Note that
7448 -- this test must be done first as a body is also classified as a
7449 -- private part.
7450
7451 if In_Package_Body (Context) then
7452 Placement := Body_State_Space;
7453 return;
7454
7455 -- The private part of a package is a cut off point for the
7456 -- traversal as the item cannot be visible to the outside from
7457 -- this point on.
7458
7459 elsif In_Private_Part (Context) then
7460 Placement := Private_State_Space;
7461 return;
7462
7463 -- When the item appears in the visible state space of a package,
7464 -- continue to climb the scope stack as this may not be the final
7465 -- state space.
7466
7467 else
7468 Placement := Visible_State_Space;
7469
7470 -- The visible state space of a child unit acts as the proper
7471 -- placement of an item.
7472
7473 if Is_Child_Unit (Context) then
7474 return;
7475 end if;
7476 end if;
7477
7478 -- The item or its enclosing package appear in a construct that has
7479 -- no state space.
7480
7481 else
7482 Placement := Not_In_Package;
7483 return;
7484 end if;
7485
7486 Context := Scope (Context);
7487 end loop;
7488 end Find_Placement_In_State_Space;
7489
7490 ------------------------
7491 -- Find_Specific_Type --
7492 ------------------------
7493
7494 function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
7495 Typ : Entity_Id := Root_Type (CW);
7496
7497 begin
7498 if Ekind (Typ) = E_Incomplete_Type then
7499 if From_Limited_With (Typ) then
7500 Typ := Non_Limited_View (Typ);
7501 else
7502 Typ := Full_View (Typ);
7503 end if;
7504 end if;
7505
7506 if Is_Private_Type (Typ)
7507 and then not Is_Tagged_Type (Typ)
7508 and then Present (Full_View (Typ))
7509 then
7510 return Full_View (Typ);
7511 else
7512 return Typ;
7513 end if;
7514 end Find_Specific_Type;
7515
7516 -----------------------------
7517 -- Find_Static_Alternative --
7518 -----------------------------
7519
7520 function Find_Static_Alternative (N : Node_Id) return Node_Id is
7521 Expr : constant Node_Id := Expression (N);
7522 Val : constant Uint := Expr_Value (Expr);
7523 Alt : Node_Id;
7524 Choice : Node_Id;
7525
7526 begin
7527 Alt := First (Alternatives (N));
7528
7529 Search : loop
7530 if Nkind (Alt) /= N_Pragma then
7531 Choice := First (Discrete_Choices (Alt));
7532 while Present (Choice) loop
7533
7534 -- Others choice, always matches
7535
7536 if Nkind (Choice) = N_Others_Choice then
7537 exit Search;
7538
7539 -- Range, check if value is in the range
7540
7541 elsif Nkind (Choice) = N_Range then
7542 exit Search when
7543 Val >= Expr_Value (Low_Bound (Choice))
7544 and then
7545 Val <= Expr_Value (High_Bound (Choice));
7546
7547 -- Choice is a subtype name. Note that we know it must
7548 -- be a static subtype, since otherwise it would have
7549 -- been diagnosed as illegal.
7550
7551 elsif Is_Entity_Name (Choice)
7552 and then Is_Type (Entity (Choice))
7553 then
7554 exit Search when Is_In_Range (Expr, Etype (Choice),
7555 Assume_Valid => False);
7556
7557 -- Choice is a subtype indication
7558
7559 elsif Nkind (Choice) = N_Subtype_Indication then
7560 declare
7561 C : constant Node_Id := Constraint (Choice);
7562 R : constant Node_Id := Range_Expression (C);
7563
7564 begin
7565 exit Search when
7566 Val >= Expr_Value (Low_Bound (R))
7567 and then
7568 Val <= Expr_Value (High_Bound (R));
7569 end;
7570
7571 -- Choice is a simple expression
7572
7573 else
7574 exit Search when Val = Expr_Value (Choice);
7575 end if;
7576
7577 Next (Choice);
7578 end loop;
7579 end if;
7580
7581 Next (Alt);
7582 pragma Assert (Present (Alt));
7583 end loop Search;
7584
7585 -- The above loop *must* terminate by finding a match, since
7586 -- we know the case statement is valid, and the value of the
7587 -- expression is known at compile time. When we fall out of
7588 -- the loop, Alt points to the alternative that we know will
7589 -- be selected at run time.
7590
7591 return Alt;
7592 end Find_Static_Alternative;
7593
7594 ------------------
7595 -- First_Actual --
7596 ------------------
7597
7598 function First_Actual (Node : Node_Id) return Node_Id is
7599 N : Node_Id;
7600
7601 begin
7602 if No (Parameter_Associations (Node)) then
7603 return Empty;
7604 end if;
7605
7606 N := First (Parameter_Associations (Node));
7607
7608 if Nkind (N) = N_Parameter_Association then
7609 return First_Named_Actual (Node);
7610 else
7611 return N;
7612 end if;
7613 end First_Actual;
7614
7615 -------------
7616 -- Fix_Msg --
7617 -------------
7618
7619 function Fix_Msg (Id : Entity_Id; Msg : String) return String is
7620 Is_Task : constant Boolean :=
7621 Ekind_In (Id, E_Task_Body, E_Task_Type)
7622 or else Is_Single_Task_Object (Id);
7623 Msg_Last : constant Natural := Msg'Last;
7624 Msg_Index : Natural;
7625 Res : String (Msg'Range) := (others => ' ');
7626 Res_Index : Natural;
7627
7628 begin
7629 -- Copy all characters from the input message Msg to result Res with
7630 -- suitable replacements.
7631
7632 Msg_Index := Msg'First;
7633 Res_Index := Res'First;
7634 while Msg_Index <= Msg_Last loop
7635
7636 -- Replace "subprogram" with a different word
7637
7638 if Msg_Index <= Msg_Last - 10
7639 and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram"
7640 then
7641 if Ekind_In (Id, E_Entry, E_Entry_Family) then
7642 Res (Res_Index .. Res_Index + 4) := "entry";
7643 Res_Index := Res_Index + 5;
7644
7645 elsif Is_Task then
7646 Res (Res_Index .. Res_Index + 8) := "task type";
7647 Res_Index := Res_Index + 9;
7648
7649 else
7650 Res (Res_Index .. Res_Index + 9) := "subprogram";
7651 Res_Index := Res_Index + 10;
7652 end if;
7653
7654 Msg_Index := Msg_Index + 10;
7655
7656 -- Replace "protected" with a different word
7657
7658 elsif Msg_Index <= Msg_Last - 9
7659 and then Msg (Msg_Index .. Msg_Index + 8) = "protected"
7660 and then Is_Task
7661 then
7662 Res (Res_Index .. Res_Index + 3) := "task";
7663 Res_Index := Res_Index + 4;
7664 Msg_Index := Msg_Index + 9;
7665
7666 -- Otherwise copy the character
7667
7668 else
7669 Res (Res_Index) := Msg (Msg_Index);
7670 Msg_Index := Msg_Index + 1;
7671 Res_Index := Res_Index + 1;
7672 end if;
7673 end loop;
7674
7675 return Res (Res'First .. Res_Index - 1);
7676 end Fix_Msg;
7677
7678 -----------------------
7679 -- Gather_Components --
7680 -----------------------
7681
7682 procedure Gather_Components
7683 (Typ : Entity_Id;
7684 Comp_List : Node_Id;
7685 Governed_By : List_Id;
7686 Into : Elist_Id;
7687 Report_Errors : out Boolean)
7688 is
7689 Assoc : Node_Id;
7690 Variant : Node_Id;
7691 Discrete_Choice : Node_Id;
7692 Comp_Item : Node_Id;
7693
7694 Discrim : Entity_Id;
7695 Discrim_Name : Node_Id;
7696 Discrim_Value : Node_Id;
7697
7698 begin
7699 Report_Errors := False;
7700
7701 if No (Comp_List) or else Null_Present (Comp_List) then
7702 return;
7703
7704 elsif Present (Component_Items (Comp_List)) then
7705 Comp_Item := First (Component_Items (Comp_List));
7706
7707 else
7708 Comp_Item := Empty;
7709 end if;
7710
7711 while Present (Comp_Item) loop
7712
7713 -- Skip the tag of a tagged record, the interface tags, as well
7714 -- as all items that are not user components (anonymous types,
7715 -- rep clauses, Parent field, controller field).
7716
7717 if Nkind (Comp_Item) = N_Component_Declaration then
7718 declare
7719 Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
7720 begin
7721 if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then
7722 Append_Elmt (Comp, Into);
7723 end if;
7724 end;
7725 end if;
7726
7727 Next (Comp_Item);
7728 end loop;
7729
7730 if No (Variant_Part (Comp_List)) then
7731 return;
7732 else
7733 Discrim_Name := Name (Variant_Part (Comp_List));
7734 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
7735 end if;
7736
7737 -- Look for the discriminant that governs this variant part.
7738 -- The discriminant *must* be in the Governed_By List
7739
7740 Assoc := First (Governed_By);
7741 Find_Constraint : loop
7742 Discrim := First (Choices (Assoc));
7743 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
7744 or else (Present (Corresponding_Discriminant (Entity (Discrim)))
7745 and then
7746 Chars (Corresponding_Discriminant (Entity (Discrim))) =
7747 Chars (Discrim_Name))
7748 or else Chars (Original_Record_Component (Entity (Discrim)))
7749 = Chars (Discrim_Name);
7750
7751 if No (Next (Assoc)) then
7752 if not Is_Constrained (Typ)
7753 and then Is_Derived_Type (Typ)
7754 and then Present (Stored_Constraint (Typ))
7755 then
7756 -- If the type is a tagged type with inherited discriminants,
7757 -- use the stored constraint on the parent in order to find
7758 -- the values of discriminants that are otherwise hidden by an
7759 -- explicit constraint. Renamed discriminants are handled in
7760 -- the code above.
7761
7762 -- If several parent discriminants are renamed by a single
7763 -- discriminant of the derived type, the call to obtain the
7764 -- Corresponding_Discriminant field only retrieves the last
7765 -- of them. We recover the constraint on the others from the
7766 -- Stored_Constraint as well.
7767
7768 declare
7769 D : Entity_Id;
7770 C : Elmt_Id;
7771
7772 begin
7773 D := First_Discriminant (Etype (Typ));
7774 C := First_Elmt (Stored_Constraint (Typ));
7775 while Present (D) and then Present (C) loop
7776 if Chars (Discrim_Name) = Chars (D) then
7777 if Is_Entity_Name (Node (C))
7778 and then Entity (Node (C)) = Entity (Discrim)
7779 then
7780 -- D is renamed by Discrim, whose value is given in
7781 -- Assoc.
7782
7783 null;
7784
7785 else
7786 Assoc :=
7787 Make_Component_Association (Sloc (Typ),
7788 New_List
7789 (New_Occurrence_Of (D, Sloc (Typ))),
7790 Duplicate_Subexpr_No_Checks (Node (C)));
7791 end if;
7792 exit Find_Constraint;
7793 end if;
7794
7795 Next_Discriminant (D);
7796 Next_Elmt (C);
7797 end loop;
7798 end;
7799 end if;
7800 end if;
7801
7802 if No (Next (Assoc)) then
7803 Error_Msg_NE (" missing value for discriminant&",
7804 First (Governed_By), Discrim_Name);
7805 Report_Errors := True;
7806 return;
7807 end if;
7808
7809 Next (Assoc);
7810 end loop Find_Constraint;
7811
7812 Discrim_Value := Expression (Assoc);
7813
7814 if not Is_OK_Static_Expression (Discrim_Value) then
7815
7816 -- If the variant part is governed by a discriminant of the type
7817 -- this is an error. If the variant part and the discriminant are
7818 -- inherited from an ancestor this is legal (AI05-120) unless the
7819 -- components are being gathered for an aggregate, in which case
7820 -- the caller must check Report_Errors.
7821
7822 if Scope (Original_Record_Component
7823 ((Entity (First (Choices (Assoc)))))) = Typ
7824 then
7825 Error_Msg_FE
7826 ("value for discriminant & must be static!",
7827 Discrim_Value, Discrim);
7828 Why_Not_Static (Discrim_Value);
7829 end if;
7830
7831 Report_Errors := True;
7832 return;
7833 end if;
7834
7835 Search_For_Discriminant_Value : declare
7836 Low : Node_Id;
7837 High : Node_Id;
7838
7839 UI_High : Uint;
7840 UI_Low : Uint;
7841 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
7842
7843 begin
7844 Find_Discrete_Value : while Present (Variant) loop
7845 Discrete_Choice := First (Discrete_Choices (Variant));
7846 while Present (Discrete_Choice) loop
7847 exit Find_Discrete_Value when
7848 Nkind (Discrete_Choice) = N_Others_Choice;
7849
7850 Get_Index_Bounds (Discrete_Choice, Low, High);
7851
7852 UI_Low := Expr_Value (Low);
7853 UI_High := Expr_Value (High);
7854
7855 exit Find_Discrete_Value when
7856 UI_Low <= UI_Discrim_Value
7857 and then
7858 UI_High >= UI_Discrim_Value;
7859
7860 Next (Discrete_Choice);
7861 end loop;
7862
7863 Next_Non_Pragma (Variant);
7864 end loop Find_Discrete_Value;
7865 end Search_For_Discriminant_Value;
7866
7867 if No (Variant) then
7868 Error_Msg_NE
7869 ("value of discriminant & is out of range", Discrim_Value, Discrim);
7870 Report_Errors := True;
7871 return;
7872 end if;
7873
7874 -- If we have found the corresponding choice, recursively add its
7875 -- components to the Into list. The nested components are part of
7876 -- the same record type.
7877
7878 Gather_Components
7879 (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
7880 end Gather_Components;
7881
7882 ------------------------
7883 -- Get_Actual_Subtype --
7884 ------------------------
7885
7886 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
7887 Typ : constant Entity_Id := Etype (N);
7888 Utyp : Entity_Id := Underlying_Type (Typ);
7889 Decl : Node_Id;
7890 Atyp : Entity_Id;
7891
7892 begin
7893 if No (Utyp) then
7894 Utyp := Typ;
7895 end if;
7896
7897 -- If what we have is an identifier that references a subprogram
7898 -- formal, or a variable or constant object, then we get the actual
7899 -- subtype from the referenced entity if one has been built.
7900
7901 if Nkind (N) = N_Identifier
7902 and then
7903 (Is_Formal (Entity (N))
7904 or else Ekind (Entity (N)) = E_Constant
7905 or else Ekind (Entity (N)) = E_Variable)
7906 and then Present (Actual_Subtype (Entity (N)))
7907 then
7908 return Actual_Subtype (Entity (N));
7909
7910 -- Actual subtype of unchecked union is always itself. We never need
7911 -- the "real" actual subtype. If we did, we couldn't get it anyway
7912 -- because the discriminant is not available. The restrictions on
7913 -- Unchecked_Union are designed to make sure that this is OK.
7914
7915 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
7916 return Typ;
7917
7918 -- Here for the unconstrained case, we must find actual subtype
7919 -- No actual subtype is available, so we must build it on the fly.
7920
7921 -- Checking the type, not the underlying type, for constrainedness
7922 -- seems to be necessary. Maybe all the tests should be on the type???
7923
7924 elsif (not Is_Constrained (Typ))
7925 and then (Is_Array_Type (Utyp)
7926 or else (Is_Record_Type (Utyp)
7927 and then Has_Discriminants (Utyp)))
7928 and then not Has_Unknown_Discriminants (Utyp)
7929 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
7930 then
7931 -- Nothing to do if in spec expression (why not???)
7932
7933 if In_Spec_Expression then
7934 return Typ;
7935
7936 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
7937
7938 -- If the type has no discriminants, there is no subtype to
7939 -- build, even if the underlying type is discriminated.
7940
7941 return Typ;
7942
7943 -- Else build the actual subtype
7944
7945 else
7946 Decl := Build_Actual_Subtype (Typ, N);
7947 Atyp := Defining_Identifier (Decl);
7948
7949 -- If Build_Actual_Subtype generated a new declaration then use it
7950
7951 if Atyp /= Typ then
7952
7953 -- The actual subtype is an Itype, so analyze the declaration,
7954 -- but do not attach it to the tree, to get the type defined.
7955
7956 Set_Parent (Decl, N);
7957 Set_Is_Itype (Atyp);
7958 Analyze (Decl, Suppress => All_Checks);
7959 Set_Associated_Node_For_Itype (Atyp, N);
7960 Set_Has_Delayed_Freeze (Atyp, False);
7961
7962 -- We need to freeze the actual subtype immediately. This is
7963 -- needed, because otherwise this Itype will not get frozen
7964 -- at all, and it is always safe to freeze on creation because
7965 -- any associated types must be frozen at this point.
7966
7967 Freeze_Itype (Atyp, N);
7968 return Atyp;
7969
7970 -- Otherwise we did not build a declaration, so return original
7971
7972 else
7973 return Typ;
7974 end if;
7975 end if;
7976
7977 -- For all remaining cases, the actual subtype is the same as
7978 -- the nominal type.
7979
7980 else
7981 return Typ;
7982 end if;
7983 end Get_Actual_Subtype;
7984
7985 -------------------------------------
7986 -- Get_Actual_Subtype_If_Available --
7987 -------------------------------------
7988
7989 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
7990 Typ : constant Entity_Id := Etype (N);
7991
7992 begin
7993 -- If what we have is an identifier that references a subprogram
7994 -- formal, or a variable or constant object, then we get the actual
7995 -- subtype from the referenced entity if one has been built.
7996
7997 if Nkind (N) = N_Identifier
7998 and then
7999 (Is_Formal (Entity (N))
8000 or else Ekind (Entity (N)) = E_Constant
8001 or else Ekind (Entity (N)) = E_Variable)
8002 and then Present (Actual_Subtype (Entity (N)))
8003 then
8004 return Actual_Subtype (Entity (N));
8005
8006 -- Otherwise the Etype of N is returned unchanged
8007
8008 else
8009 return Typ;
8010 end if;
8011 end Get_Actual_Subtype_If_Available;
8012
8013 ------------------------
8014 -- Get_Body_From_Stub --
8015 ------------------------
8016
8017 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
8018 begin
8019 return Proper_Body (Unit (Library_Unit (N)));
8020 end Get_Body_From_Stub;
8021
8022 ---------------------
8023 -- Get_Cursor_Type --
8024 ---------------------
8025
8026 function Get_Cursor_Type
8027 (Aspect : Node_Id;
8028 Typ : Entity_Id) return Entity_Id
8029 is
8030 Assoc : Node_Id;
8031 Func : Entity_Id;
8032 First_Op : Entity_Id;
8033 Cursor : Entity_Id;
8034
8035 begin
8036 -- If error already detected, return
8037
8038 if Error_Posted (Aspect) then
8039 return Any_Type;
8040 end if;
8041
8042 -- The cursor type for an Iterable aspect is the return type of a
8043 -- non-overloaded First primitive operation. Locate association for
8044 -- First.
8045
8046 Assoc := First (Component_Associations (Expression (Aspect)));
8047 First_Op := Any_Id;
8048 while Present (Assoc) loop
8049 if Chars (First (Choices (Assoc))) = Name_First then
8050 First_Op := Expression (Assoc);
8051 exit;
8052 end if;
8053
8054 Next (Assoc);
8055 end loop;
8056
8057 if First_Op = Any_Id then
8058 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
8059 return Any_Type;
8060 end if;
8061
8062 Cursor := Any_Type;
8063
8064 -- Locate function with desired name and profile in scope of type
8065 -- In the rare case where the type is an integer type, a base type
8066 -- is created for it, check that the base type of the first formal
8067 -- of First matches the base type of the domain.
8068
8069 Func := First_Entity (Scope (Typ));
8070 while Present (Func) loop
8071 if Chars (Func) = Chars (First_Op)
8072 and then Ekind (Func) = E_Function
8073 and then Present (First_Formal (Func))
8074 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ)
8075 and then No (Next_Formal (First_Formal (Func)))
8076 then
8077 if Cursor /= Any_Type then
8078 Error_Msg_N
8079 ("Operation First for iterable type must be unique", Aspect);
8080 return Any_Type;
8081 else
8082 Cursor := Etype (Func);
8083 end if;
8084 end if;
8085
8086 Next_Entity (Func);
8087 end loop;
8088
8089 -- If not found, no way to resolve remaining primitives.
8090
8091 if Cursor = Any_Type then
8092 Error_Msg_N
8093 ("No legal primitive operation First for Iterable type", Aspect);
8094 end if;
8095
8096 return Cursor;
8097 end Get_Cursor_Type;
8098
8099 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
8100 begin
8101 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First));
8102 end Get_Cursor_Type;
8103
8104 -------------------------------
8105 -- Get_Default_External_Name --
8106 -------------------------------
8107
8108 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
8109 begin
8110 Get_Decoded_Name_String (Chars (E));
8111
8112 if Opt.External_Name_Imp_Casing = Uppercase then
8113 Set_Casing (All_Upper_Case);
8114 else
8115 Set_Casing (All_Lower_Case);
8116 end if;
8117
8118 return
8119 Make_String_Literal (Sloc (E),
8120 Strval => String_From_Name_Buffer);
8121 end Get_Default_External_Name;
8122
8123 --------------------------
8124 -- Get_Enclosing_Object --
8125 --------------------------
8126
8127 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
8128 begin
8129 if Is_Entity_Name (N) then
8130 return Entity (N);
8131 else
8132 case Nkind (N) is
8133 when N_Indexed_Component |
8134 N_Slice |
8135 N_Selected_Component =>
8136
8137 -- If not generating code, a dereference may be left implicit.
8138 -- In thoses cases, return Empty.
8139
8140 if Is_Access_Type (Etype (Prefix (N))) then
8141 return Empty;
8142 else
8143 return Get_Enclosing_Object (Prefix (N));
8144 end if;
8145
8146 when N_Type_Conversion =>
8147 return Get_Enclosing_Object (Expression (N));
8148
8149 when others =>
8150 return Empty;
8151 end case;
8152 end if;
8153 end Get_Enclosing_Object;
8154
8155 ---------------------------
8156 -- Get_Enum_Lit_From_Pos --
8157 ---------------------------
8158
8159 function Get_Enum_Lit_From_Pos
8160 (T : Entity_Id;
8161 Pos : Uint;
8162 Loc : Source_Ptr) return Node_Id
8163 is
8164 Btyp : Entity_Id := Base_Type (T);
8165 Lit : Node_Id;
8166
8167 begin
8168 -- In the case where the literal is of type Character, Wide_Character
8169 -- or Wide_Wide_Character or of a type derived from them, there needs
8170 -- to be some special handling since there is no explicit chain of
8171 -- literals to search. Instead, an N_Character_Literal node is created
8172 -- with the appropriate Char_Code and Chars fields.
8173
8174 if Is_Standard_Character_Type (T) then
8175 Set_Character_Literal_Name (UI_To_CC (Pos));
8176 return
8177 Make_Character_Literal (Loc,
8178 Chars => Name_Find,
8179 Char_Literal_Value => Pos);
8180
8181 -- For all other cases, we have a complete table of literals, and
8182 -- we simply iterate through the chain of literal until the one
8183 -- with the desired position value is found.
8184
8185 else
8186 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
8187 Btyp := Full_View (Btyp);
8188 end if;
8189
8190 Lit := First_Literal (Btyp);
8191 for J in 1 .. UI_To_Int (Pos) loop
8192 Next_Literal (Lit);
8193 end loop;
8194
8195 return New_Occurrence_Of (Lit, Loc);
8196 end if;
8197 end Get_Enum_Lit_From_Pos;
8198
8199 ------------------------
8200 -- Get_Generic_Entity --
8201 ------------------------
8202
8203 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
8204 Ent : constant Entity_Id := Entity (Name (N));
8205 begin
8206 if Present (Renamed_Object (Ent)) then
8207 return Renamed_Object (Ent);
8208 else
8209 return Ent;
8210 end if;
8211 end Get_Generic_Entity;
8212
8213 -------------------------------------
8214 -- Get_Incomplete_View_Of_Ancestor --
8215 -------------------------------------
8216
8217 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
8218 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
8219 Par_Scope : Entity_Id;
8220 Par_Type : Entity_Id;
8221
8222 begin
8223 -- The incomplete view of an ancestor is only relevant for private
8224 -- derived types in child units.
8225
8226 if not Is_Derived_Type (E)
8227 or else not Is_Child_Unit (Cur_Unit)
8228 then
8229 return Empty;
8230
8231 else
8232 Par_Scope := Scope (Cur_Unit);
8233 if No (Par_Scope) then
8234 return Empty;
8235 end if;
8236
8237 Par_Type := Etype (Base_Type (E));
8238
8239 -- Traverse list of ancestor types until we find one declared in
8240 -- a parent or grandparent unit (two levels seem sufficient).
8241
8242 while Present (Par_Type) loop
8243 if Scope (Par_Type) = Par_Scope
8244 or else Scope (Par_Type) = Scope (Par_Scope)
8245 then
8246 return Par_Type;
8247
8248 elsif not Is_Derived_Type (Par_Type) then
8249 return Empty;
8250
8251 else
8252 Par_Type := Etype (Base_Type (Par_Type));
8253 end if;
8254 end loop;
8255
8256 -- If none found, there is no relevant ancestor type.
8257
8258 return Empty;
8259 end if;
8260 end Get_Incomplete_View_Of_Ancestor;
8261
8262 ----------------------
8263 -- Get_Index_Bounds --
8264 ----------------------
8265
8266 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
8267 Kind : constant Node_Kind := Nkind (N);
8268 R : Node_Id;
8269
8270 begin
8271 if Kind = N_Range then
8272 L := Low_Bound (N);
8273 H := High_Bound (N);
8274
8275 elsif Kind = N_Subtype_Indication then
8276 R := Range_Expression (Constraint (N));
8277
8278 if R = Error then
8279 L := Error;
8280 H := Error;
8281 return;
8282
8283 else
8284 L := Low_Bound (Range_Expression (Constraint (N)));
8285 H := High_Bound (Range_Expression (Constraint (N)));
8286 end if;
8287
8288 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
8289 if Error_Posted (Scalar_Range (Entity (N))) then
8290 L := Error;
8291 H := Error;
8292
8293 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
8294 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
8295
8296 else
8297 L := Low_Bound (Scalar_Range (Entity (N)));
8298 H := High_Bound (Scalar_Range (Entity (N)));
8299 end if;
8300
8301 else
8302 -- N is an expression, indicating a range with one value
8303
8304 L := N;
8305 H := N;
8306 end if;
8307 end Get_Index_Bounds;
8308
8309 ---------------------------------
8310 -- Get_Iterable_Type_Primitive --
8311 ---------------------------------
8312
8313 function Get_Iterable_Type_Primitive
8314 (Typ : Entity_Id;
8315 Nam : Name_Id) return Entity_Id
8316 is
8317 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
8318 Assoc : Node_Id;
8319
8320 begin
8321 if No (Funcs) then
8322 return Empty;
8323
8324 else
8325 Assoc := First (Component_Associations (Funcs));
8326 while Present (Assoc) loop
8327 if Chars (First (Choices (Assoc))) = Nam then
8328 return Entity (Expression (Assoc));
8329 end if;
8330
8331 Assoc := Next (Assoc);
8332 end loop;
8333
8334 return Empty;
8335 end if;
8336 end Get_Iterable_Type_Primitive;
8337
8338 ----------------------------------
8339 -- Get_Library_Unit_Name_string --
8340 ----------------------------------
8341
8342 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
8343 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
8344
8345 begin
8346 Get_Unit_Name_String (Unit_Name_Id);
8347
8348 -- Remove seven last character (" (spec)" or " (body)")
8349
8350 Name_Len := Name_Len - 7;
8351 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
8352 end Get_Library_Unit_Name_String;
8353
8354 ------------------------
8355 -- Get_Name_Entity_Id --
8356 ------------------------
8357
8358 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
8359 begin
8360 return Entity_Id (Get_Name_Table_Int (Id));
8361 end Get_Name_Entity_Id;
8362
8363 ------------------------------
8364 -- Get_Name_From_CTC_Pragma --
8365 ------------------------------
8366
8367 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
8368 Arg : constant Node_Id :=
8369 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
8370 begin
8371 return Strval (Expr_Value_S (Arg));
8372 end Get_Name_From_CTC_Pragma;
8373
8374 -----------------------
8375 -- Get_Parent_Entity --
8376 -----------------------
8377
8378 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
8379 begin
8380 if Nkind (Unit) = N_Package_Body
8381 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
8382 then
8383 return Defining_Entity
8384 (Specification (Instance_Spec (Original_Node (Unit))));
8385 elsif Nkind (Unit) = N_Package_Instantiation then
8386 return Defining_Entity (Specification (Instance_Spec (Unit)));
8387 else
8388 return Defining_Entity (Unit);
8389 end if;
8390 end Get_Parent_Entity;
8391
8392 -------------------
8393 -- Get_Pragma_Id --
8394 -------------------
8395
8396 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
8397 begin
8398 return Get_Pragma_Id (Pragma_Name (N));
8399 end Get_Pragma_Id;
8400
8401 ------------------------
8402 -- Get_Qualified_Name --
8403 ------------------------
8404
8405 function Get_Qualified_Name
8406 (Id : Entity_Id;
8407 Suffix : Entity_Id := Empty) return Name_Id
8408 is
8409 Suffix_Nam : Name_Id := No_Name;
8410
8411 begin
8412 if Present (Suffix) then
8413 Suffix_Nam := Chars (Suffix);
8414 end if;
8415
8416 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
8417 end Get_Qualified_Name;
8418
8419 function Get_Qualified_Name
8420 (Nam : Name_Id;
8421 Suffix : Name_Id := No_Name;
8422 Scop : Entity_Id := Current_Scope) return Name_Id
8423 is
8424 procedure Add_Scope (S : Entity_Id);
8425 -- Add the fully qualified form of scope S to the name buffer. The
8426 -- format is:
8427 -- s-1__s__
8428
8429 ---------------
8430 -- Add_Scope --
8431 ---------------
8432
8433 procedure Add_Scope (S : Entity_Id) is
8434 begin
8435 if S = Empty then
8436 null;
8437
8438 elsif S = Standard_Standard then
8439 null;
8440
8441 else
8442 Add_Scope (Scope (S));
8443 Get_Name_String_And_Append (Chars (S));
8444 Add_Str_To_Name_Buffer ("__");
8445 end if;
8446 end Add_Scope;
8447
8448 -- Start of processing for Get_Qualified_Name
8449
8450 begin
8451 Name_Len := 0;
8452 Add_Scope (Scop);
8453
8454 -- Append the base name after all scopes have been chained
8455
8456 Get_Name_String_And_Append (Nam);
8457
8458 -- Append the suffix (if present)
8459
8460 if Suffix /= No_Name then
8461 Add_Str_To_Name_Buffer ("__");
8462 Get_Name_String_And_Append (Suffix);
8463 end if;
8464
8465 return Name_Find;
8466 end Get_Qualified_Name;
8467
8468 -----------------------
8469 -- Get_Reason_String --
8470 -----------------------
8471
8472 procedure Get_Reason_String (N : Node_Id) is
8473 begin
8474 if Nkind (N) = N_String_Literal then
8475 Store_String_Chars (Strval (N));
8476
8477 elsif Nkind (N) = N_Op_Concat then
8478 Get_Reason_String (Left_Opnd (N));
8479 Get_Reason_String (Right_Opnd (N));
8480
8481 -- If not of required form, error
8482
8483 else
8484 Error_Msg_N
8485 ("Reason for pragma Warnings has wrong form", N);
8486 Error_Msg_N
8487 ("\must be string literal or concatenation of string literals", N);
8488 return;
8489 end if;
8490 end Get_Reason_String;
8491
8492 --------------------------------
8493 -- Get_Reference_Discriminant --
8494 --------------------------------
8495
8496 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is
8497 D : Entity_Id;
8498
8499 begin
8500 D := First_Discriminant (Typ);
8501 while Present (D) loop
8502 if Has_Implicit_Dereference (D) then
8503 return D;
8504 end if;
8505 Next_Discriminant (D);
8506 end loop;
8507
8508 return Empty;
8509 end Get_Reference_Discriminant;
8510
8511 ---------------------------
8512 -- Get_Referenced_Object --
8513 ---------------------------
8514
8515 function Get_Referenced_Object (N : Node_Id) return Node_Id is
8516 R : Node_Id;
8517
8518 begin
8519 R := N;
8520 while Is_Entity_Name (R)
8521 and then Present (Renamed_Object (Entity (R)))
8522 loop
8523 R := Renamed_Object (Entity (R));
8524 end loop;
8525
8526 return R;
8527 end Get_Referenced_Object;
8528
8529 ------------------------
8530 -- Get_Renamed_Entity --
8531 ------------------------
8532
8533 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
8534 R : Entity_Id;
8535
8536 begin
8537 R := E;
8538 while Present (Renamed_Entity (R)) loop
8539 R := Renamed_Entity (R);
8540 end loop;
8541
8542 return R;
8543 end Get_Renamed_Entity;
8544
8545 -----------------------
8546 -- Get_Return_Object --
8547 -----------------------
8548
8549 function Get_Return_Object (N : Node_Id) return Entity_Id is
8550 Decl : Node_Id;
8551
8552 begin
8553 Decl := First (Return_Object_Declarations (N));
8554 while Present (Decl) loop
8555 exit when Nkind (Decl) = N_Object_Declaration
8556 and then Is_Return_Object (Defining_Identifier (Decl));
8557 Next (Decl);
8558 end loop;
8559
8560 pragma Assert (Present (Decl));
8561 return Defining_Identifier (Decl);
8562 end Get_Return_Object;
8563
8564 ---------------------------
8565 -- Get_Subprogram_Entity --
8566 ---------------------------
8567
8568 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
8569 Subp : Node_Id;
8570 Subp_Id : Entity_Id;
8571
8572 begin
8573 if Nkind (Nod) = N_Accept_Statement then
8574 Subp := Entry_Direct_Name (Nod);
8575
8576 elsif Nkind (Nod) = N_Slice then
8577 Subp := Prefix (Nod);
8578
8579 else
8580 Subp := Name (Nod);
8581 end if;
8582
8583 -- Strip the subprogram call
8584
8585 loop
8586 if Nkind_In (Subp, N_Explicit_Dereference,
8587 N_Indexed_Component,
8588 N_Selected_Component)
8589 then
8590 Subp := Prefix (Subp);
8591
8592 elsif Nkind_In (Subp, N_Type_Conversion,
8593 N_Unchecked_Type_Conversion)
8594 then
8595 Subp := Expression (Subp);
8596
8597 else
8598 exit;
8599 end if;
8600 end loop;
8601
8602 -- Extract the entity of the subprogram call
8603
8604 if Is_Entity_Name (Subp) then
8605 Subp_Id := Entity (Subp);
8606
8607 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
8608 Subp_Id := Directly_Designated_Type (Subp_Id);
8609 end if;
8610
8611 if Is_Subprogram (Subp_Id) then
8612 return Subp_Id;
8613 else
8614 return Empty;
8615 end if;
8616
8617 -- The search did not find a construct that denotes a subprogram
8618
8619 else
8620 return Empty;
8621 end if;
8622 end Get_Subprogram_Entity;
8623
8624 -----------------------------
8625 -- Get_Task_Body_Procedure --
8626 -----------------------------
8627
8628 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
8629 begin
8630 -- Note: A task type may be the completion of a private type with
8631 -- discriminants. When performing elaboration checks on a task
8632 -- declaration, the current view of the type may be the private one,
8633 -- and the procedure that holds the body of the task is held in its
8634 -- underlying type.
8635
8636 -- This is an odd function, why not have Task_Body_Procedure do
8637 -- the following digging???
8638
8639 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
8640 end Get_Task_Body_Procedure;
8641
8642 -------------------------
8643 -- Get_User_Defined_Eq --
8644 -------------------------
8645
8646 function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is
8647 Prim : Elmt_Id;
8648 Op : Entity_Id;
8649
8650 begin
8651 Prim := First_Elmt (Collect_Primitive_Operations (E));
8652 while Present (Prim) loop
8653 Op := Node (Prim);
8654
8655 if Chars (Op) = Name_Op_Eq
8656 and then Etype (Op) = Standard_Boolean
8657 and then Etype (First_Formal (Op)) = E
8658 and then Etype (Next_Formal (First_Formal (Op))) = E
8659 then
8660 return Op;
8661 end if;
8662
8663 Next_Elmt (Prim);
8664 end loop;
8665
8666 return Empty;
8667 end Get_User_Defined_Eq;
8668
8669 ---------------
8670 -- Get_Views --
8671 ---------------
8672
8673 procedure Get_Views
8674 (Typ : Entity_Id;
8675 Priv_Typ : out Entity_Id;
8676 Full_Typ : out Entity_Id;
8677 Full_Base : out Entity_Id;
8678 CRec_Typ : out Entity_Id)
8679 is
8680 begin
8681 -- Assume that none of the views can be recovered
8682
8683 Priv_Typ := Empty;
8684 Full_Typ := Empty;
8685 Full_Base := Empty;
8686 CRec_Typ := Empty;
8687
8688 -- The input type is private
8689
8690 if Is_Private_Type (Typ) then
8691 Priv_Typ := Typ;
8692 Full_Typ := Full_View (Priv_Typ);
8693
8694 if Present (Full_Typ) then
8695 Full_Base := Base_Type (Full_Typ);
8696
8697 if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then
8698 CRec_Typ := Corresponding_Record_Type (Full_Typ);
8699 end if;
8700 end if;
8701
8702 -- The input type is the corresponding record type of a protected or a
8703 -- task type.
8704
8705 elsif Ekind (Typ) = E_Record_Type
8706 and then Is_Concurrent_Record_Type (Typ)
8707 then
8708 CRec_Typ := Typ;
8709 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
8710 Full_Base := Base_Type (Full_Typ);
8711 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
8712
8713 -- Otherwise the input type could be the full view of a private type
8714
8715 else
8716 Full_Typ := Typ;
8717 Full_Base := Base_Type (Full_Typ);
8718
8719 if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then
8720 CRec_Typ := Corresponding_Record_Type (Full_Typ);
8721 end if;
8722
8723 -- The type is the full view of a private type, obtain the partial
8724 -- view.
8725
8726 if Has_Private_Declaration (Full_Typ)
8727 and then not Is_Private_Type (Full_Typ)
8728 then
8729 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
8730
8731 -- The full view of a private type should always have a partial
8732 -- view.
8733
8734 pragma Assert (Present (Priv_Typ));
8735 end if;
8736 end if;
8737 end Get_Views;
8738
8739 -----------------------
8740 -- Has_Access_Values --
8741 -----------------------
8742
8743 function Has_Access_Values (T : Entity_Id) return Boolean is
8744 Typ : constant Entity_Id := Underlying_Type (T);
8745
8746 begin
8747 -- Case of a private type which is not completed yet. This can only
8748 -- happen in the case of a generic format type appearing directly, or
8749 -- as a component of the type to which this function is being applied
8750 -- at the top level. Return False in this case, since we certainly do
8751 -- not know that the type contains access types.
8752
8753 if No (Typ) then
8754 return False;
8755
8756 elsif Is_Access_Type (Typ) then
8757 return True;
8758
8759 elsif Is_Array_Type (Typ) then
8760 return Has_Access_Values (Component_Type (Typ));
8761
8762 elsif Is_Record_Type (Typ) then
8763 declare
8764 Comp : Entity_Id;
8765
8766 begin
8767 -- Loop to Check components
8768
8769 Comp := First_Component_Or_Discriminant (Typ);
8770 while Present (Comp) loop
8771
8772 -- Check for access component, tag field does not count, even
8773 -- though it is implemented internally using an access type.
8774
8775 if Has_Access_Values (Etype (Comp))
8776 and then Chars (Comp) /= Name_uTag
8777 then
8778 return True;
8779 end if;
8780
8781 Next_Component_Or_Discriminant (Comp);
8782 end loop;
8783 end;
8784
8785 return False;
8786
8787 else
8788 return False;
8789 end if;
8790 end Has_Access_Values;
8791
8792 ------------------------------
8793 -- Has_Compatible_Alignment --
8794 ------------------------------
8795
8796 function Has_Compatible_Alignment
8797 (Obj : Entity_Id;
8798 Expr : Node_Id;
8799 Layout_Done : Boolean) return Alignment_Result
8800 is
8801 function Has_Compatible_Alignment_Internal
8802 (Obj : Entity_Id;
8803 Expr : Node_Id;
8804 Layout_Done : Boolean;
8805 Default : Alignment_Result) return Alignment_Result;
8806 -- This is the internal recursive function that actually does the work.
8807 -- There is one additional parameter, which says what the result should
8808 -- be if no alignment information is found, and there is no definite
8809 -- indication of compatible alignments. At the outer level, this is set
8810 -- to Unknown, but for internal recursive calls in the case where types
8811 -- are known to be correct, it is set to Known_Compatible.
8812
8813 ---------------------------------------
8814 -- Has_Compatible_Alignment_Internal --
8815 ---------------------------------------
8816
8817 function Has_Compatible_Alignment_Internal
8818 (Obj : Entity_Id;
8819 Expr : Node_Id;
8820 Layout_Done : Boolean;
8821 Default : Alignment_Result) return Alignment_Result
8822 is
8823 Result : Alignment_Result := Known_Compatible;
8824 -- Holds the current status of the result. Note that once a value of
8825 -- Known_Incompatible is set, it is sticky and does not get changed
8826 -- to Unknown (the value in Result only gets worse as we go along,
8827 -- never better).
8828
8829 Offs : Uint := No_Uint;
8830 -- Set to a factor of the offset from the base object when Expr is a
8831 -- selected or indexed component, based on Component_Bit_Offset and
8832 -- Component_Size respectively. A negative value is used to represent
8833 -- a value which is not known at compile time.
8834
8835 procedure Check_Prefix;
8836 -- Checks the prefix recursively in the case where the expression
8837 -- is an indexed or selected component.
8838
8839 procedure Set_Result (R : Alignment_Result);
8840 -- If R represents a worse outcome (unknown instead of known
8841 -- compatible, or known incompatible), then set Result to R.
8842
8843 ------------------
8844 -- Check_Prefix --
8845 ------------------
8846
8847 procedure Check_Prefix is
8848 begin
8849 -- The subtlety here is that in doing a recursive call to check
8850 -- the prefix, we have to decide what to do in the case where we
8851 -- don't find any specific indication of an alignment problem.
8852
8853 -- At the outer level, we normally set Unknown as the result in
8854 -- this case, since we can only set Known_Compatible if we really
8855 -- know that the alignment value is OK, but for the recursive
8856 -- call, in the case where the types match, and we have not
8857 -- specified a peculiar alignment for the object, we are only
8858 -- concerned about suspicious rep clauses, the default case does
8859 -- not affect us, since the compiler will, in the absence of such
8860 -- rep clauses, ensure that the alignment is correct.
8861
8862 if Default = Known_Compatible
8863 or else
8864 (Etype (Obj) = Etype (Expr)
8865 and then (Unknown_Alignment (Obj)
8866 or else
8867 Alignment (Obj) = Alignment (Etype (Obj))))
8868 then
8869 Set_Result
8870 (Has_Compatible_Alignment_Internal
8871 (Obj, Prefix (Expr), Layout_Done, Known_Compatible));
8872
8873 -- In all other cases, we need a full check on the prefix
8874
8875 else
8876 Set_Result
8877 (Has_Compatible_Alignment_Internal
8878 (Obj, Prefix (Expr), Layout_Done, Unknown));
8879 end if;
8880 end Check_Prefix;
8881
8882 ----------------
8883 -- Set_Result --
8884 ----------------
8885
8886 procedure Set_Result (R : Alignment_Result) is
8887 begin
8888 if R > Result then
8889 Result := R;
8890 end if;
8891 end Set_Result;
8892
8893 -- Start of processing for Has_Compatible_Alignment_Internal
8894
8895 begin
8896 -- If Expr is a selected component, we must make sure there is no
8897 -- potentially troublesome component clause and that the record is
8898 -- not packed if the layout is not done.
8899
8900 if Nkind (Expr) = N_Selected_Component then
8901
8902 -- Packing generates unknown alignment if layout is not done
8903
8904 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then
8905 Set_Result (Unknown);
8906 end if;
8907
8908 -- Check prefix and component offset
8909
8910 Check_Prefix;
8911 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
8912
8913 -- If Expr is an indexed component, we must make sure there is no
8914 -- potentially troublesome Component_Size clause and that the array
8915 -- is not bit-packed if the layout is not done.
8916
8917 elsif Nkind (Expr) = N_Indexed_Component then
8918 declare
8919 Typ : constant Entity_Id := Etype (Prefix (Expr));
8920
8921 begin
8922 -- Packing generates unknown alignment if layout is not done
8923
8924 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then
8925 Set_Result (Unknown);
8926 end if;
8927
8928 -- Check prefix and component offset (or at least size)
8929
8930 Check_Prefix;
8931 Offs := Indexed_Component_Bit_Offset (Expr);
8932 if Offs = No_Uint then
8933 Offs := Component_Size (Typ);
8934 end if;
8935 end;
8936 end if;
8937
8938 -- If we have a null offset, the result is entirely determined by
8939 -- the base object and has already been computed recursively.
8940
8941 if Offs = Uint_0 then
8942 null;
8943
8944 -- Case where we know the alignment of the object
8945
8946 elsif Known_Alignment (Obj) then
8947 declare
8948 ObjA : constant Uint := Alignment (Obj);
8949 ExpA : Uint := No_Uint;
8950 SizA : Uint := No_Uint;
8951
8952 begin
8953 -- If alignment of Obj is 1, then we are always OK
8954
8955 if ObjA = 1 then
8956 Set_Result (Known_Compatible);
8957
8958 -- Alignment of Obj is greater than 1, so we need to check
8959
8960 else
8961 -- If we have an offset, see if it is compatible
8962
8963 if Offs /= No_Uint and Offs > Uint_0 then
8964 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
8965 Set_Result (Known_Incompatible);
8966 end if;
8967
8968 -- See if Expr is an object with known alignment
8969
8970 elsif Is_Entity_Name (Expr)
8971 and then Known_Alignment (Entity (Expr))
8972 then
8973 ExpA := Alignment (Entity (Expr));
8974
8975 -- Otherwise, we can use the alignment of the type of
8976 -- Expr given that we already checked for
8977 -- discombobulating rep clauses for the cases of indexed
8978 -- and selected components above.
8979
8980 elsif Known_Alignment (Etype (Expr)) then
8981 ExpA := Alignment (Etype (Expr));
8982
8983 -- Otherwise the alignment is unknown
8984
8985 else
8986 Set_Result (Default);
8987 end if;
8988
8989 -- If we got an alignment, see if it is acceptable
8990
8991 if ExpA /= No_Uint and then ExpA < ObjA then
8992 Set_Result (Known_Incompatible);
8993 end if;
8994
8995 -- If Expr is not a piece of a larger object, see if size
8996 -- is given. If so, check that it is not too small for the
8997 -- required alignment.
8998
8999 if Offs /= No_Uint then
9000 null;
9001
9002 -- See if Expr is an object with known size
9003
9004 elsif Is_Entity_Name (Expr)
9005 and then Known_Static_Esize (Entity (Expr))
9006 then
9007 SizA := Esize (Entity (Expr));
9008
9009 -- Otherwise, we check the object size of the Expr type
9010
9011 elsif Known_Static_Esize (Etype (Expr)) then
9012 SizA := Esize (Etype (Expr));
9013 end if;
9014
9015 -- If we got a size, see if it is a multiple of the Obj
9016 -- alignment, if not, then the alignment cannot be
9017 -- acceptable, since the size is always a multiple of the
9018 -- alignment.
9019
9020 if SizA /= No_Uint then
9021 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
9022 Set_Result (Known_Incompatible);
9023 end if;
9024 end if;
9025 end if;
9026 end;
9027
9028 -- If we do not know required alignment, any non-zero offset is a
9029 -- potential problem (but certainly may be OK, so result is unknown).
9030
9031 elsif Offs /= No_Uint then
9032 Set_Result (Unknown);
9033
9034 -- If we can't find the result by direct comparison of alignment
9035 -- values, then there is still one case that we can determine known
9036 -- result, and that is when we can determine that the types are the
9037 -- same, and no alignments are specified. Then we known that the
9038 -- alignments are compatible, even if we don't know the alignment
9039 -- value in the front end.
9040
9041 elsif Etype (Obj) = Etype (Expr) then
9042
9043 -- Types are the same, but we have to check for possible size
9044 -- and alignments on the Expr object that may make the alignment
9045 -- different, even though the types are the same.
9046
9047 if Is_Entity_Name (Expr) then
9048
9049 -- First check alignment of the Expr object. Any alignment less
9050 -- than Maximum_Alignment is worrisome since this is the case
9051 -- where we do not know the alignment of Obj.
9052
9053 if Known_Alignment (Entity (Expr))
9054 and then UI_To_Int (Alignment (Entity (Expr))) <
9055 Ttypes.Maximum_Alignment
9056 then
9057 Set_Result (Unknown);
9058
9059 -- Now check size of Expr object. Any size that is not an
9060 -- even multiple of Maximum_Alignment is also worrisome
9061 -- since it may cause the alignment of the object to be less
9062 -- than the alignment of the type.
9063
9064 elsif Known_Static_Esize (Entity (Expr))
9065 and then
9066 (UI_To_Int (Esize (Entity (Expr))) mod
9067 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
9068 /= 0
9069 then
9070 Set_Result (Unknown);
9071
9072 -- Otherwise same type is decisive
9073
9074 else
9075 Set_Result (Known_Compatible);
9076 end if;
9077 end if;
9078
9079 -- Another case to deal with is when there is an explicit size or
9080 -- alignment clause when the types are not the same. If so, then the
9081 -- result is Unknown. We don't need to do this test if the Default is
9082 -- Unknown, since that result will be set in any case.
9083
9084 elsif Default /= Unknown
9085 and then (Has_Size_Clause (Etype (Expr))
9086 or else
9087 Has_Alignment_Clause (Etype (Expr)))
9088 then
9089 Set_Result (Unknown);
9090
9091 -- If no indication found, set default
9092
9093 else
9094 Set_Result (Default);
9095 end if;
9096
9097 -- Return worst result found
9098
9099 return Result;
9100 end Has_Compatible_Alignment_Internal;
9101
9102 -- Start of processing for Has_Compatible_Alignment
9103
9104 begin
9105 -- If Obj has no specified alignment, then set alignment from the type
9106 -- alignment. Perhaps we should always do this, but for sure we should
9107 -- do it when there is an address clause since we can do more if the
9108 -- alignment is known.
9109
9110 if Unknown_Alignment (Obj) then
9111 Set_Alignment (Obj, Alignment (Etype (Obj)));
9112 end if;
9113
9114 -- Now do the internal call that does all the work
9115
9116 return
9117 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown);
9118 end Has_Compatible_Alignment;
9119
9120 ----------------------
9121 -- Has_Declarations --
9122 ----------------------
9123
9124 function Has_Declarations (N : Node_Id) return Boolean is
9125 begin
9126 return Nkind_In (Nkind (N), N_Accept_Statement,
9127 N_Block_Statement,
9128 N_Compilation_Unit_Aux,
9129 N_Entry_Body,
9130 N_Package_Body,
9131 N_Protected_Body,
9132 N_Subprogram_Body,
9133 N_Task_Body,
9134 N_Package_Specification);
9135 end Has_Declarations;
9136
9137 ---------------------------------
9138 -- Has_Defaulted_Discriminants --
9139 ---------------------------------
9140
9141 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
9142 begin
9143 return Has_Discriminants (Typ)
9144 and then Present (First_Discriminant (Typ))
9145 and then Present (Discriminant_Default_Value
9146 (First_Discriminant (Typ)));
9147 end Has_Defaulted_Discriminants;
9148
9149 -------------------
9150 -- Has_Denormals --
9151 -------------------
9152
9153 function Has_Denormals (E : Entity_Id) return Boolean is
9154 begin
9155 return Is_Floating_Point_Type (E) and then Denorm_On_Target;
9156 end Has_Denormals;
9157
9158 -------------------------------------------
9159 -- Has_Discriminant_Dependent_Constraint --
9160 -------------------------------------------
9161
9162 function Has_Discriminant_Dependent_Constraint
9163 (Comp : Entity_Id) return Boolean
9164 is
9165 Comp_Decl : constant Node_Id := Parent (Comp);
9166 Subt_Indic : Node_Id;
9167 Constr : Node_Id;
9168 Assn : Node_Id;
9169
9170 begin
9171 -- Discriminants can't depend on discriminants
9172
9173 if Ekind (Comp) = E_Discriminant then
9174 return False;
9175
9176 else
9177 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
9178
9179 if Nkind (Subt_Indic) = N_Subtype_Indication then
9180 Constr := Constraint (Subt_Indic);
9181
9182 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
9183 Assn := First (Constraints (Constr));
9184 while Present (Assn) loop
9185 case Nkind (Assn) is
9186 when N_Subtype_Indication |
9187 N_Range |
9188 N_Identifier
9189 =>
9190 if Depends_On_Discriminant (Assn) then
9191 return True;
9192 end if;
9193
9194 when N_Discriminant_Association =>
9195 if Depends_On_Discriminant (Expression (Assn)) then
9196 return True;
9197 end if;
9198
9199 when others =>
9200 null;
9201 end case;
9202
9203 Next (Assn);
9204 end loop;
9205 end if;
9206 end if;
9207 end if;
9208
9209 return False;
9210 end Has_Discriminant_Dependent_Constraint;
9211
9212 --------------------------------------
9213 -- Has_Effectively_Volatile_Profile --
9214 --------------------------------------
9215
9216 function Has_Effectively_Volatile_Profile
9217 (Subp_Id : Entity_Id) return Boolean
9218 is
9219 Formal : Entity_Id;
9220
9221 begin
9222 -- Inspect the formal parameters looking for an effectively volatile
9223 -- type.
9224
9225 Formal := First_Formal (Subp_Id);
9226 while Present (Formal) loop
9227 if Is_Effectively_Volatile (Etype (Formal)) then
9228 return True;
9229 end if;
9230
9231 Next_Formal (Formal);
9232 end loop;
9233
9234 -- Inspect the return type of functions
9235
9236 if Ekind_In (Subp_Id, E_Function, E_Generic_Function)
9237 and then Is_Effectively_Volatile (Etype (Subp_Id))
9238 then
9239 return True;
9240 end if;
9241
9242 return False;
9243 end Has_Effectively_Volatile_Profile;
9244
9245 --------------------------
9246 -- Has_Enabled_Property --
9247 --------------------------
9248
9249 function Has_Enabled_Property
9250 (Item_Id : Entity_Id;
9251 Property : Name_Id) return Boolean
9252 is
9253 function State_Has_Enabled_Property return Boolean;
9254 -- Determine whether a state denoted by Item_Id has the property enabled
9255
9256 function Variable_Has_Enabled_Property return Boolean;
9257 -- Determine whether a variable denoted by Item_Id has the property
9258 -- enabled.
9259
9260 --------------------------------
9261 -- State_Has_Enabled_Property --
9262 --------------------------------
9263
9264 function State_Has_Enabled_Property return Boolean is
9265 Decl : constant Node_Id := Parent (Item_Id);
9266 Opt : Node_Id;
9267 Opt_Nam : Node_Id;
9268 Prop : Node_Id;
9269 Prop_Nam : Node_Id;
9270 Props : Node_Id;
9271
9272 begin
9273 -- The declaration of an external abstract state appears as an
9274 -- extension aggregate. If this is not the case, properties can never
9275 -- be set.
9276
9277 if Nkind (Decl) /= N_Extension_Aggregate then
9278 return False;
9279 end if;
9280
9281 -- When External appears as a simple option, it automatically enables
9282 -- all properties.
9283
9284 Opt := First (Expressions (Decl));
9285 while Present (Opt) loop
9286 if Nkind (Opt) = N_Identifier
9287 and then Chars (Opt) = Name_External
9288 then
9289 return True;
9290 end if;
9291
9292 Next (Opt);
9293 end loop;
9294
9295 -- When External specifies particular properties, inspect those and
9296 -- find the desired one (if any).
9297
9298 Opt := First (Component_Associations (Decl));
9299 while Present (Opt) loop
9300 Opt_Nam := First (Choices (Opt));
9301
9302 if Nkind (Opt_Nam) = N_Identifier
9303 and then Chars (Opt_Nam) = Name_External
9304 then
9305 Props := Expression (Opt);
9306
9307 -- Multiple properties appear as an aggregate
9308
9309 if Nkind (Props) = N_Aggregate then
9310
9311 -- Simple property form
9312
9313 Prop := First (Expressions (Props));
9314 while Present (Prop) loop
9315 if Chars (Prop) = Property then
9316 return True;
9317 end if;
9318
9319 Next (Prop);
9320 end loop;
9321
9322 -- Property with expression form
9323
9324 Prop := First (Component_Associations (Props));
9325 while Present (Prop) loop
9326 Prop_Nam := First (Choices (Prop));
9327
9328 -- The property can be represented in two ways:
9329 -- others => <value>
9330 -- <property> => <value>
9331
9332 if Nkind (Prop_Nam) = N_Others_Choice
9333 or else (Nkind (Prop_Nam) = N_Identifier
9334 and then Chars (Prop_Nam) = Property)
9335 then
9336 return Is_True (Expr_Value (Expression (Prop)));
9337 end if;
9338
9339 Next (Prop);
9340 end loop;
9341
9342 -- Single property
9343
9344 else
9345 return Chars (Props) = Property;
9346 end if;
9347 end if;
9348
9349 Next (Opt);
9350 end loop;
9351
9352 return False;
9353 end State_Has_Enabled_Property;
9354
9355 -----------------------------------
9356 -- Variable_Has_Enabled_Property --
9357 -----------------------------------
9358
9359 function Variable_Has_Enabled_Property return Boolean is
9360 function Is_Enabled (Prag : Node_Id) return Boolean;
9361 -- Determine whether property pragma Prag (if present) denotes an
9362 -- enabled property.
9363
9364 ----------------
9365 -- Is_Enabled --
9366 ----------------
9367
9368 function Is_Enabled (Prag : Node_Id) return Boolean is
9369 Arg1 : Node_Id;
9370
9371 begin
9372 if Present (Prag) then
9373 Arg1 := First (Pragma_Argument_Associations (Prag));
9374
9375 -- The pragma has an optional Boolean expression, the related
9376 -- property is enabled only when the expression evaluates to
9377 -- True.
9378
9379 if Present (Arg1) then
9380 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1)));
9381
9382 -- Otherwise the lack of expression enables the property by
9383 -- default.
9384
9385 else
9386 return True;
9387 end if;
9388
9389 -- The property was never set in the first place
9390
9391 else
9392 return False;
9393 end if;
9394 end Is_Enabled;
9395
9396 -- Local variables
9397
9398 AR : constant Node_Id :=
9399 Get_Pragma (Item_Id, Pragma_Async_Readers);
9400 AW : constant Node_Id :=
9401 Get_Pragma (Item_Id, Pragma_Async_Writers);
9402 ER : constant Node_Id :=
9403 Get_Pragma (Item_Id, Pragma_Effective_Reads);
9404 EW : constant Node_Id :=
9405 Get_Pragma (Item_Id, Pragma_Effective_Writes);
9406
9407 -- Start of processing for Variable_Has_Enabled_Property
9408
9409 begin
9410 -- A non-effectively volatile object can never possess external
9411 -- properties.
9412
9413 if not Is_Effectively_Volatile (Item_Id) then
9414 return False;
9415
9416 -- External properties related to variables come in two flavors -
9417 -- explicit and implicit. The explicit case is characterized by the
9418 -- presence of a property pragma with an optional Boolean flag. The
9419 -- property is enabled when the flag evaluates to True or the flag is
9420 -- missing altogether.
9421
9422 elsif Property = Name_Async_Readers and then Is_Enabled (AR) then
9423 return True;
9424
9425 elsif Property = Name_Async_Writers and then Is_Enabled (AW) then
9426 return True;
9427
9428 elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then
9429 return True;
9430
9431 elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then
9432 return True;
9433
9434 -- The implicit case lacks all property pragmas
9435
9436 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
9437 return True;
9438
9439 else
9440 return False;
9441 end if;
9442 end Variable_Has_Enabled_Property;
9443
9444 -- Start of processing for Has_Enabled_Property
9445
9446 begin
9447 -- Abstract states and variables have a flexible scheme of specifying
9448 -- external properties.
9449
9450 if Ekind (Item_Id) = E_Abstract_State then
9451 return State_Has_Enabled_Property;
9452
9453 elsif Ekind (Item_Id) = E_Variable then
9454 return Variable_Has_Enabled_Property;
9455
9456 -- Otherwise a property is enabled when the related item is effectively
9457 -- volatile.
9458
9459 else
9460 return Is_Effectively_Volatile (Item_Id);
9461 end if;
9462 end Has_Enabled_Property;
9463
9464 -------------------------------------
9465 -- Has_Full_Default_Initialization --
9466 -------------------------------------
9467
9468 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
9469 Arg : Node_Id;
9470 Comp : Entity_Id;
9471 Prag : Node_Id;
9472
9473 begin
9474 -- A private type and its full view is fully default initialized when it
9475 -- is subject to pragma Default_Initial_Condition without an argument or
9476 -- with a non-null argument. Since any type may act as the full view of
9477 -- a private type, this check must be performed prior to the specialized
9478 -- tests below.
9479
9480 if Has_Default_Init_Cond (Typ)
9481 or else Has_Inherited_Default_Init_Cond (Typ)
9482 then
9483 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
9484
9485 -- Pragma Default_Initial_Condition must be present if one of the
9486 -- related entity flags is set.
9487
9488 pragma Assert (Present (Prag));
9489 Arg := First (Pragma_Argument_Associations (Prag));
9490
9491 -- A non-null argument guarantees full default initialization
9492
9493 if Present (Arg) then
9494 return Nkind (Arg) /= N_Null;
9495
9496 -- Otherwise the missing argument defaults the pragma to "True" which
9497 -- is considered a non-null argument (see above).
9498
9499 else
9500 return True;
9501 end if;
9502 end if;
9503
9504 -- A scalar type is fully default initialized if it is subject to aspect
9505 -- Default_Value.
9506
9507 if Is_Scalar_Type (Typ) then
9508 return Has_Default_Aspect (Typ);
9509
9510 -- An array type is fully default initialized if its element type is
9511 -- scalar and the array type carries aspect Default_Component_Value or
9512 -- the element type is fully default initialized.
9513
9514 elsif Is_Array_Type (Typ) then
9515 return
9516 Has_Default_Aspect (Typ)
9517 or else Has_Full_Default_Initialization (Component_Type (Typ));
9518
9519 -- A protected type, record type, or type extension is fully default
9520 -- initialized if all its components either carry an initialization
9521 -- expression or have a type that is fully default initialized. The
9522 -- parent type of a type extension must be fully default initialized.
9523
9524 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
9525
9526 -- Inspect all entities defined in the scope of the type, looking for
9527 -- uninitialized components.
9528
9529 Comp := First_Entity (Typ);
9530 while Present (Comp) loop
9531 if Ekind (Comp) = E_Component
9532 and then Comes_From_Source (Comp)
9533 and then No (Expression (Parent (Comp)))
9534 and then not Has_Full_Default_Initialization (Etype (Comp))
9535 then
9536 return False;
9537 end if;
9538
9539 Next_Entity (Comp);
9540 end loop;
9541
9542 -- Ensure that the parent type of a type extension is fully default
9543 -- initialized.
9544
9545 if Etype (Typ) /= Typ
9546 and then not Has_Full_Default_Initialization (Etype (Typ))
9547 then
9548 return False;
9549 end if;
9550
9551 -- If we get here, then all components and parent portion are fully
9552 -- default initialized.
9553
9554 return True;
9555
9556 -- A task type is fully default initialized by default
9557
9558 elsif Is_Task_Type (Typ) then
9559 return True;
9560
9561 -- Otherwise the type is not fully default initialized
9562
9563 else
9564 return False;
9565 end if;
9566 end Has_Full_Default_Initialization;
9567
9568 --------------------
9569 -- Has_Infinities --
9570 --------------------
9571
9572 function Has_Infinities (E : Entity_Id) return Boolean is
9573 begin
9574 return
9575 Is_Floating_Point_Type (E)
9576 and then Nkind (Scalar_Range (E)) = N_Range
9577 and then Includes_Infinities (Scalar_Range (E));
9578 end Has_Infinities;
9579
9580 --------------------
9581 -- Has_Interfaces --
9582 --------------------
9583
9584 function Has_Interfaces
9585 (T : Entity_Id;
9586 Use_Full_View : Boolean := True) return Boolean
9587 is
9588 Typ : Entity_Id := Base_Type (T);
9589
9590 begin
9591 -- Handle concurrent types
9592
9593 if Is_Concurrent_Type (Typ) then
9594 Typ := Corresponding_Record_Type (Typ);
9595 end if;
9596
9597 if not Present (Typ)
9598 or else not Is_Record_Type (Typ)
9599 or else not Is_Tagged_Type (Typ)
9600 then
9601 return False;
9602 end if;
9603
9604 -- Handle private types
9605
9606 if Use_Full_View and then Present (Full_View (Typ)) then
9607 Typ := Full_View (Typ);
9608 end if;
9609
9610 -- Handle concurrent record types
9611
9612 if Is_Concurrent_Record_Type (Typ)
9613 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
9614 then
9615 return True;
9616 end if;
9617
9618 loop
9619 if Is_Interface (Typ)
9620 or else
9621 (Is_Record_Type (Typ)
9622 and then Present (Interfaces (Typ))
9623 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
9624 then
9625 return True;
9626 end if;
9627
9628 exit when Etype (Typ) = Typ
9629
9630 -- Handle private types
9631
9632 or else (Present (Full_View (Etype (Typ)))
9633 and then Full_View (Etype (Typ)) = Typ)
9634
9635 -- Protect frontend against wrong sources with cyclic derivations
9636
9637 or else Etype (Typ) = T;
9638
9639 -- Climb to the ancestor type handling private types
9640
9641 if Present (Full_View (Etype (Typ))) then
9642 Typ := Full_View (Etype (Typ));
9643 else
9644 Typ := Etype (Typ);
9645 end if;
9646 end loop;
9647
9648 return False;
9649 end Has_Interfaces;
9650
9651 ---------------------------------
9652 -- Has_No_Obvious_Side_Effects --
9653 ---------------------------------
9654
9655 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
9656 begin
9657 -- For now, just handle literals, constants, and non-volatile
9658 -- variables and expressions combining these with operators or
9659 -- short circuit forms.
9660
9661 if Nkind (N) in N_Numeric_Or_String_Literal then
9662 return True;
9663
9664 elsif Nkind (N) = N_Character_Literal then
9665 return True;
9666
9667 elsif Nkind (N) in N_Unary_Op then
9668 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
9669
9670 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
9671 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
9672 and then
9673 Has_No_Obvious_Side_Effects (Right_Opnd (N));
9674
9675 elsif Nkind (N) = N_Expression_With_Actions
9676 and then Is_Empty_List (Actions (N))
9677 then
9678 return Has_No_Obvious_Side_Effects (Expression (N));
9679
9680 elsif Nkind (N) in N_Has_Entity then
9681 return Present (Entity (N))
9682 and then Ekind_In (Entity (N), E_Variable,
9683 E_Constant,
9684 E_Enumeration_Literal,
9685 E_In_Parameter,
9686 E_Out_Parameter,
9687 E_In_Out_Parameter)
9688 and then not Is_Volatile (Entity (N));
9689
9690 else
9691 return False;
9692 end if;
9693 end Has_No_Obvious_Side_Effects;
9694
9695 -----------------------------
9696 -- Has_Non_Null_Refinement --
9697 -----------------------------
9698
9699 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is
9700 Constits : Elist_Id;
9701
9702 begin
9703 pragma Assert (Ekind (Id) = E_Abstract_State);
9704 Constits := Refinement_Constituents (Id);
9705
9706 -- For a refinement to be non-null, the first constituent must be
9707 -- anything other than null.
9708
9709 return
9710 Present (Constits)
9711 and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
9712 end Has_Non_Null_Refinement;
9713
9714 -------------------
9715 -- Has_Null_Body --
9716 -------------------
9717
9718 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
9719 Body_Id : Entity_Id;
9720 Decl : Node_Id;
9721 Spec : Node_Id;
9722 Stmt1 : Node_Id;
9723 Stmt2 : Node_Id;
9724
9725 begin
9726 Spec := Parent (Proc_Id);
9727 Decl := Parent (Spec);
9728
9729 -- Retrieve the entity of the procedure body (e.g. invariant proc).
9730
9731 if Nkind (Spec) = N_Procedure_Specification
9732 and then Nkind (Decl) = N_Subprogram_Declaration
9733 then
9734 Body_Id := Corresponding_Body (Decl);
9735
9736 -- The body acts as a spec
9737
9738 else
9739 Body_Id := Proc_Id;
9740 end if;
9741
9742 -- The body will be generated later
9743
9744 if No (Body_Id) then
9745 return False;
9746 end if;
9747
9748 Spec := Parent (Body_Id);
9749 Decl := Parent (Spec);
9750
9751 pragma Assert
9752 (Nkind (Spec) = N_Procedure_Specification
9753 and then Nkind (Decl) = N_Subprogram_Body);
9754
9755 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
9756
9757 -- Look for a null statement followed by an optional return
9758 -- statement.
9759
9760 if Nkind (Stmt1) = N_Null_Statement then
9761 Stmt2 := Next (Stmt1);
9762
9763 if Present (Stmt2) then
9764 return Nkind (Stmt2) = N_Simple_Return_Statement;
9765 else
9766 return True;
9767 end if;
9768 end if;
9769
9770 return False;
9771 end Has_Null_Body;
9772
9773 ------------------------
9774 -- Has_Null_Exclusion --
9775 ------------------------
9776
9777 function Has_Null_Exclusion (N : Node_Id) return Boolean is
9778 begin
9779 case Nkind (N) is
9780 when N_Access_Definition |
9781 N_Access_Function_Definition |
9782 N_Access_Procedure_Definition |
9783 N_Access_To_Object_Definition |
9784 N_Allocator |
9785 N_Derived_Type_Definition |
9786 N_Function_Specification |
9787 N_Subtype_Declaration =>
9788 return Null_Exclusion_Present (N);
9789
9790 when N_Component_Definition |
9791 N_Formal_Object_Declaration |
9792 N_Object_Renaming_Declaration =>
9793 if Present (Subtype_Mark (N)) then
9794 return Null_Exclusion_Present (N);
9795 else pragma Assert (Present (Access_Definition (N)));
9796 return Null_Exclusion_Present (Access_Definition (N));
9797 end if;
9798
9799 when N_Discriminant_Specification =>
9800 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
9801 return Null_Exclusion_Present (Discriminant_Type (N));
9802 else
9803 return Null_Exclusion_Present (N);
9804 end if;
9805
9806 when N_Object_Declaration =>
9807 if Nkind (Object_Definition (N)) = N_Access_Definition then
9808 return Null_Exclusion_Present (Object_Definition (N));
9809 else
9810 return Null_Exclusion_Present (N);
9811 end if;
9812
9813 when N_Parameter_Specification =>
9814 if Nkind (Parameter_Type (N)) = N_Access_Definition then
9815 return Null_Exclusion_Present (Parameter_Type (N));
9816 else
9817 return Null_Exclusion_Present (N);
9818 end if;
9819
9820 when others =>
9821 return False;
9822
9823 end case;
9824 end Has_Null_Exclusion;
9825
9826 ------------------------
9827 -- Has_Null_Extension --
9828 ------------------------
9829
9830 function Has_Null_Extension (T : Entity_Id) return Boolean is
9831 B : constant Entity_Id := Base_Type (T);
9832 Comps : Node_Id;
9833 Ext : Node_Id;
9834
9835 begin
9836 if Nkind (Parent (B)) = N_Full_Type_Declaration
9837 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
9838 then
9839 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
9840
9841 if Present (Ext) then
9842 if Null_Present (Ext) then
9843 return True;
9844 else
9845 Comps := Component_List (Ext);
9846
9847 -- The null component list is rewritten during analysis to
9848 -- include the parent component. Any other component indicates
9849 -- that the extension was not originally null.
9850
9851 return Null_Present (Comps)
9852 or else No (Next (First (Component_Items (Comps))));
9853 end if;
9854 else
9855 return False;
9856 end if;
9857
9858 else
9859 return False;
9860 end if;
9861 end Has_Null_Extension;
9862
9863 -------------------------
9864 -- Has_Null_Refinement --
9865 -------------------------
9866
9867 function Has_Null_Refinement (Id : Entity_Id) return Boolean is
9868 Constits : Elist_Id;
9869
9870 begin
9871 pragma Assert (Ekind (Id) = E_Abstract_State);
9872 Constits := Refinement_Constituents (Id);
9873
9874 -- For a refinement to be null, the state's sole constituent must be a
9875 -- null.
9876
9877 return
9878 Present (Constits)
9879 and then Nkind (Node (First_Elmt (Constits))) = N_Null;
9880 end Has_Null_Refinement;
9881
9882 -------------------------------
9883 -- Has_Overriding_Initialize --
9884 -------------------------------
9885
9886 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
9887 BT : constant Entity_Id := Base_Type (T);
9888 P : Elmt_Id;
9889
9890 begin
9891 if Is_Controlled (BT) then
9892 if Is_RTU (Scope (BT), Ada_Finalization) then
9893 return False;
9894
9895 elsif Present (Primitive_Operations (BT)) then
9896 P := First_Elmt (Primitive_Operations (BT));
9897 while Present (P) loop
9898 declare
9899 Init : constant Entity_Id := Node (P);
9900 Formal : constant Entity_Id := First_Formal (Init);
9901 begin
9902 if Ekind (Init) = E_Procedure
9903 and then Chars (Init) = Name_Initialize
9904 and then Comes_From_Source (Init)
9905 and then Present (Formal)
9906 and then Etype (Formal) = BT
9907 and then No (Next_Formal (Formal))
9908 and then (Ada_Version < Ada_2012
9909 or else not Null_Present (Parent (Init)))
9910 then
9911 return True;
9912 end if;
9913 end;
9914
9915 Next_Elmt (P);
9916 end loop;
9917 end if;
9918
9919 -- Here if type itself does not have a non-null Initialize operation:
9920 -- check immediate ancestor.
9921
9922 if Is_Derived_Type (BT)
9923 and then Has_Overriding_Initialize (Etype (BT))
9924 then
9925 return True;
9926 end if;
9927 end if;
9928
9929 return False;
9930 end Has_Overriding_Initialize;
9931
9932 --------------------------------------
9933 -- Has_Preelaborable_Initialization --
9934 --------------------------------------
9935
9936 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
9937 Has_PE : Boolean;
9938
9939 procedure Check_Components (E : Entity_Id);
9940 -- Check component/discriminant chain, sets Has_PE False if a component
9941 -- or discriminant does not meet the preelaborable initialization rules.
9942
9943 ----------------------
9944 -- Check_Components --
9945 ----------------------
9946
9947 procedure Check_Components (E : Entity_Id) is
9948 Ent : Entity_Id;
9949 Exp : Node_Id;
9950
9951 function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
9952 -- Returns True if and only if the expression denoted by N does not
9953 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
9954
9955 ---------------------------------
9956 -- Is_Preelaborable_Expression --
9957 ---------------------------------
9958
9959 function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
9960 Exp : Node_Id;
9961 Assn : Node_Id;
9962 Choice : Node_Id;
9963 Comp_Type : Entity_Id;
9964 Is_Array_Aggr : Boolean;
9965
9966 begin
9967 if Is_OK_Static_Expression (N) then
9968 return True;
9969
9970 elsif Nkind (N) = N_Null then
9971 return True;
9972
9973 -- Attributes are allowed in general, even if their prefix is a
9974 -- formal type. (It seems that certain attributes known not to be
9975 -- static might not be allowed, but there are no rules to prevent
9976 -- them.)
9977
9978 elsif Nkind (N) = N_Attribute_Reference then
9979 return True;
9980
9981 -- The name of a discriminant evaluated within its parent type is
9982 -- defined to be preelaborable (10.2.1(8)). Note that we test for
9983 -- names that denote discriminals as well as discriminants to
9984 -- catch references occurring within init procs.
9985
9986 elsif Is_Entity_Name (N)
9987 and then
9988 (Ekind (Entity (N)) = E_Discriminant
9989 or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter)
9990 and then Present (Discriminal_Link (Entity (N)))))
9991 then
9992 return True;
9993
9994 elsif Nkind (N) = N_Qualified_Expression then
9995 return Is_Preelaborable_Expression (Expression (N));
9996
9997 -- For aggregates we have to check that each of the associations
9998 -- is preelaborable.
9999
10000 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
10001 Is_Array_Aggr := Is_Array_Type (Etype (N));
10002
10003 if Is_Array_Aggr then
10004 Comp_Type := Component_Type (Etype (N));
10005 end if;
10006
10007 -- Check the ancestor part of extension aggregates, which must
10008 -- be either the name of a type that has preelaborable init or
10009 -- an expression that is preelaborable.
10010
10011 if Nkind (N) = N_Extension_Aggregate then
10012 declare
10013 Anc_Part : constant Node_Id := Ancestor_Part (N);
10014
10015 begin
10016 if Is_Entity_Name (Anc_Part)
10017 and then Is_Type (Entity (Anc_Part))
10018 then
10019 if not Has_Preelaborable_Initialization
10020 (Entity (Anc_Part))
10021 then
10022 return False;
10023 end if;
10024
10025 elsif not Is_Preelaborable_Expression (Anc_Part) then
10026 return False;
10027 end if;
10028 end;
10029 end if;
10030
10031 -- Check positional associations
10032
10033 Exp := First (Expressions (N));
10034 while Present (Exp) loop
10035 if not Is_Preelaborable_Expression (Exp) then
10036 return False;
10037 end if;
10038
10039 Next (Exp);
10040 end loop;
10041
10042 -- Check named associations
10043
10044 Assn := First (Component_Associations (N));
10045 while Present (Assn) loop
10046 Choice := First (Choices (Assn));
10047 while Present (Choice) loop
10048 if Is_Array_Aggr then
10049 if Nkind (Choice) = N_Others_Choice then
10050 null;
10051
10052 elsif Nkind (Choice) = N_Range then
10053 if not Is_OK_Static_Range (Choice) then
10054 return False;
10055 end if;
10056
10057 elsif not Is_OK_Static_Expression (Choice) then
10058 return False;
10059 end if;
10060
10061 else
10062 Comp_Type := Etype (Choice);
10063 end if;
10064
10065 Next (Choice);
10066 end loop;
10067
10068 -- If the association has a <> at this point, then we have
10069 -- to check whether the component's type has preelaborable
10070 -- initialization. Note that this only occurs when the
10071 -- association's corresponding component does not have a
10072 -- default expression, the latter case having already been
10073 -- expanded as an expression for the association.
10074
10075 if Box_Present (Assn) then
10076 if not Has_Preelaborable_Initialization (Comp_Type) then
10077 return False;
10078 end if;
10079
10080 -- In the expression case we check whether the expression
10081 -- is preelaborable.
10082
10083 elsif
10084 not Is_Preelaborable_Expression (Expression (Assn))
10085 then
10086 return False;
10087 end if;
10088
10089 Next (Assn);
10090 end loop;
10091
10092 -- If we get here then aggregate as a whole is preelaborable
10093
10094 return True;
10095
10096 -- All other cases are not preelaborable
10097
10098 else
10099 return False;
10100 end if;
10101 end Is_Preelaborable_Expression;
10102
10103 -- Start of processing for Check_Components
10104
10105 begin
10106 -- Loop through entities of record or protected type
10107
10108 Ent := E;
10109 while Present (Ent) loop
10110
10111 -- We are interested only in components and discriminants
10112
10113 Exp := Empty;
10114
10115 case Ekind (Ent) is
10116 when E_Component =>
10117
10118 -- Get default expression if any. If there is no declaration
10119 -- node, it means we have an internal entity. The parent and
10120 -- tag fields are examples of such entities. For such cases,
10121 -- we just test the type of the entity.
10122
10123 if Present (Declaration_Node (Ent)) then
10124 Exp := Expression (Declaration_Node (Ent));
10125 end if;
10126
10127 when E_Discriminant =>
10128
10129 -- Note: for a renamed discriminant, the Declaration_Node
10130 -- may point to the one from the ancestor, and have a
10131 -- different expression, so use the proper attribute to
10132 -- retrieve the expression from the derived constraint.
10133
10134 Exp := Discriminant_Default_Value (Ent);
10135
10136 when others =>
10137 goto Check_Next_Entity;
10138 end case;
10139
10140 -- A component has PI if it has no default expression and the
10141 -- component type has PI.
10142
10143 if No (Exp) then
10144 if not Has_Preelaborable_Initialization (Etype (Ent)) then
10145 Has_PE := False;
10146 exit;
10147 end if;
10148
10149 -- Require the default expression to be preelaborable
10150
10151 elsif not Is_Preelaborable_Expression (Exp) then
10152 Has_PE := False;
10153 exit;
10154 end if;
10155
10156 <<Check_Next_Entity>>
10157 Next_Entity (Ent);
10158 end loop;
10159 end Check_Components;
10160
10161 -- Start of processing for Has_Preelaborable_Initialization
10162
10163 begin
10164 -- Immediate return if already marked as known preelaborable init. This
10165 -- covers types for which this function has already been called once
10166 -- and returned True (in which case the result is cached), and also
10167 -- types to which a pragma Preelaborable_Initialization applies.
10168
10169 if Known_To_Have_Preelab_Init (E) then
10170 return True;
10171 end if;
10172
10173 -- If the type is a subtype representing a generic actual type, then
10174 -- test whether its base type has preelaborable initialization since
10175 -- the subtype representing the actual does not inherit this attribute
10176 -- from the actual or formal. (but maybe it should???)
10177
10178 if Is_Generic_Actual_Type (E) then
10179 return Has_Preelaborable_Initialization (Base_Type (E));
10180 end if;
10181
10182 -- All elementary types have preelaborable initialization
10183
10184 if Is_Elementary_Type (E) then
10185 Has_PE := True;
10186
10187 -- Array types have PI if the component type has PI
10188
10189 elsif Is_Array_Type (E) then
10190 Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
10191
10192 -- A derived type has preelaborable initialization if its parent type
10193 -- has preelaborable initialization and (in the case of a derived record
10194 -- extension) if the non-inherited components all have preelaborable
10195 -- initialization. However, a user-defined controlled type with an
10196 -- overriding Initialize procedure does not have preelaborable
10197 -- initialization.
10198
10199 elsif Is_Derived_Type (E) then
10200
10201 -- If the derived type is a private extension then it doesn't have
10202 -- preelaborable initialization.
10203
10204 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
10205 return False;
10206 end if;
10207
10208 -- First check whether ancestor type has preelaborable initialization
10209
10210 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
10211
10212 -- If OK, check extension components (if any)
10213
10214 if Has_PE and then Is_Record_Type (E) then
10215 Check_Components (First_Entity (E));
10216 end if;
10217
10218 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
10219 -- with a user defined Initialize procedure does not have PI. If
10220 -- the type is untagged, the control primitives come from a component
10221 -- that has already been checked.
10222
10223 if Has_PE
10224 and then Is_Controlled (E)
10225 and then Is_Tagged_Type (E)
10226 and then Has_Overriding_Initialize (E)
10227 then
10228 Has_PE := False;
10229 end if;
10230
10231 -- Private types not derived from a type having preelaborable init and
10232 -- that are not marked with pragma Preelaborable_Initialization do not
10233 -- have preelaborable initialization.
10234
10235 elsif Is_Private_Type (E) then
10236 return False;
10237
10238 -- Record type has PI if it is non private and all components have PI
10239
10240 elsif Is_Record_Type (E) then
10241 Has_PE := True;
10242 Check_Components (First_Entity (E));
10243
10244 -- Protected types must not have entries, and components must meet
10245 -- same set of rules as for record components.
10246
10247 elsif Is_Protected_Type (E) then
10248 if Has_Entries (E) then
10249 Has_PE := False;
10250 else
10251 Has_PE := True;
10252 Check_Components (First_Entity (E));
10253 Check_Components (First_Private_Entity (E));
10254 end if;
10255
10256 -- Type System.Address always has preelaborable initialization
10257
10258 elsif Is_RTE (E, RE_Address) then
10259 Has_PE := True;
10260
10261 -- In all other cases, type does not have preelaborable initialization
10262
10263 else
10264 return False;
10265 end if;
10266
10267 -- If type has preelaborable initialization, cache result
10268
10269 if Has_PE then
10270 Set_Known_To_Have_Preelab_Init (E);
10271 end if;
10272
10273 return Has_PE;
10274 end Has_Preelaborable_Initialization;
10275
10276 ---------------------------
10277 -- Has_Private_Component --
10278 ---------------------------
10279
10280 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
10281 Btype : Entity_Id := Base_Type (Type_Id);
10282 Component : Entity_Id;
10283
10284 begin
10285 if Error_Posted (Type_Id)
10286 or else Error_Posted (Btype)
10287 then
10288 return False;
10289 end if;
10290
10291 if Is_Class_Wide_Type (Btype) then
10292 Btype := Root_Type (Btype);
10293 end if;
10294
10295 if Is_Private_Type (Btype) then
10296 declare
10297 UT : constant Entity_Id := Underlying_Type (Btype);
10298 begin
10299 if No (UT) then
10300 if No (Full_View (Btype)) then
10301 return not Is_Generic_Type (Btype)
10302 and then
10303 not Is_Generic_Type (Root_Type (Btype));
10304 else
10305 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
10306 end if;
10307 else
10308 return not Is_Frozen (UT) and then Has_Private_Component (UT);
10309 end if;
10310 end;
10311
10312 elsif Is_Array_Type (Btype) then
10313 return Has_Private_Component (Component_Type (Btype));
10314
10315 elsif Is_Record_Type (Btype) then
10316 Component := First_Component (Btype);
10317 while Present (Component) loop
10318 if Has_Private_Component (Etype (Component)) then
10319 return True;
10320 end if;
10321
10322 Next_Component (Component);
10323 end loop;
10324
10325 return False;
10326
10327 elsif Is_Protected_Type (Btype)
10328 and then Present (Corresponding_Record_Type (Btype))
10329 then
10330 return Has_Private_Component (Corresponding_Record_Type (Btype));
10331
10332 else
10333 return False;
10334 end if;
10335 end Has_Private_Component;
10336
10337 ----------------------
10338 -- Has_Signed_Zeros --
10339 ----------------------
10340
10341 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
10342 begin
10343 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
10344 end Has_Signed_Zeros;
10345
10346 ------------------------------
10347 -- Has_Significant_Contract --
10348 ------------------------------
10349
10350 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is
10351 Subp_Nam : constant Name_Id := Chars (Subp_Id);
10352
10353 begin
10354 -- _Finalizer procedure
10355
10356 if Subp_Nam = Name_uFinalizer then
10357 return False;
10358
10359 -- _Postconditions procedure
10360
10361 elsif Subp_Nam = Name_uPostconditions then
10362 return False;
10363
10364 -- Predicate function
10365
10366 elsif Ekind (Subp_Id) = E_Function
10367 and then Is_Predicate_Function (Subp_Id)
10368 then
10369 return False;
10370
10371 -- TSS subprogram
10372
10373 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then
10374 return False;
10375
10376 else
10377 return True;
10378 end if;
10379 end Has_Significant_Contract;
10380
10381 -----------------------------
10382 -- Has_Static_Array_Bounds --
10383 -----------------------------
10384
10385 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
10386 Ndims : constant Nat := Number_Dimensions (Typ);
10387
10388 Index : Node_Id;
10389 Low : Node_Id;
10390 High : Node_Id;
10391
10392 begin
10393 -- Unconstrained types do not have static bounds
10394
10395 if not Is_Constrained (Typ) then
10396 return False;
10397 end if;
10398
10399 -- First treat string literals specially, as the lower bound and length
10400 -- of string literals are not stored like those of arrays.
10401
10402 -- A string literal always has static bounds
10403
10404 if Ekind (Typ) = E_String_Literal_Subtype then
10405 return True;
10406 end if;
10407
10408 -- Treat all dimensions in turn
10409
10410 Index := First_Index (Typ);
10411 for Indx in 1 .. Ndims loop
10412
10413 -- In case of an illegal index which is not a discrete type, return
10414 -- that the type is not static.
10415
10416 if not Is_Discrete_Type (Etype (Index))
10417 or else Etype (Index) = Any_Type
10418 then
10419 return False;
10420 end if;
10421
10422 Get_Index_Bounds (Index, Low, High);
10423
10424 if Error_Posted (Low) or else Error_Posted (High) then
10425 return False;
10426 end if;
10427
10428 if Is_OK_Static_Expression (Low)
10429 and then
10430 Is_OK_Static_Expression (High)
10431 then
10432 null;
10433 else
10434 return False;
10435 end if;
10436
10437 Next (Index);
10438 end loop;
10439
10440 -- If we fall through the loop, all indexes matched
10441
10442 return True;
10443 end Has_Static_Array_Bounds;
10444
10445 ----------------
10446 -- Has_Stream --
10447 ----------------
10448
10449 function Has_Stream (T : Entity_Id) return Boolean is
10450 E : Entity_Id;
10451
10452 begin
10453 if No (T) then
10454 return False;
10455
10456 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
10457 return True;
10458
10459 elsif Is_Array_Type (T) then
10460 return Has_Stream (Component_Type (T));
10461
10462 elsif Is_Record_Type (T) then
10463 E := First_Component (T);
10464 while Present (E) loop
10465 if Has_Stream (Etype (E)) then
10466 return True;
10467 else
10468 Next_Component (E);
10469 end if;
10470 end loop;
10471
10472 return False;
10473
10474 elsif Is_Private_Type (T) then
10475 return Has_Stream (Underlying_Type (T));
10476
10477 else
10478 return False;
10479 end if;
10480 end Has_Stream;
10481
10482 ----------------
10483 -- Has_Suffix --
10484 ----------------
10485
10486 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
10487 begin
10488 Get_Name_String (Chars (E));
10489 return Name_Buffer (Name_Len) = Suffix;
10490 end Has_Suffix;
10491
10492 ----------------
10493 -- Add_Suffix --
10494 ----------------
10495
10496 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
10497 begin
10498 Get_Name_String (Chars (E));
10499 Add_Char_To_Name_Buffer (Suffix);
10500 return Name_Find;
10501 end Add_Suffix;
10502
10503 -------------------
10504 -- Remove_Suffix --
10505 -------------------
10506
10507 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
10508 begin
10509 pragma Assert (Has_Suffix (E, Suffix));
10510 Get_Name_String (Chars (E));
10511 Name_Len := Name_Len - 1;
10512 return Name_Find;
10513 end Remove_Suffix;
10514
10515 ----------------------------------
10516 -- Replace_Null_By_Null_Address --
10517 ----------------------------------
10518
10519 procedure Replace_Null_By_Null_Address (N : Node_Id) is
10520 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id);
10521 -- Replace operand Op with a reference to Null_Address when the operand
10522 -- denotes a null Address. Other_Op denotes the other operand.
10523
10524 --------------------------
10525 -- Replace_Null_Operand --
10526 --------------------------
10527
10528 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is
10529 begin
10530 -- Check the type of the complementary operand since the N_Null node
10531 -- has not been decorated yet.
10532
10533 if Nkind (Op) = N_Null
10534 and then Is_Descendant_Of_Address (Etype (Other_Op))
10535 then
10536 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op)));
10537 end if;
10538 end Replace_Null_Operand;
10539
10540 -- Start of processing for Replace_Null_By_Null_Address
10541
10542 begin
10543 pragma Assert (Relaxed_RM_Semantics);
10544 pragma Assert (Nkind_In (N, N_Null,
10545 N_Op_Eq,
10546 N_Op_Ge,
10547 N_Op_Gt,
10548 N_Op_Le,
10549 N_Op_Lt,
10550 N_Op_Ne));
10551
10552 if Nkind (N) = N_Null then
10553 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
10554
10555 else
10556 declare
10557 L : constant Node_Id := Left_Opnd (N);
10558 R : constant Node_Id := Right_Opnd (N);
10559
10560 begin
10561 Replace_Null_Operand (L, Other_Op => R);
10562 Replace_Null_Operand (R, Other_Op => L);
10563 end;
10564 end if;
10565 end Replace_Null_By_Null_Address;
10566
10567 --------------------------
10568 -- Has_Tagged_Component --
10569 --------------------------
10570
10571 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
10572 Comp : Entity_Id;
10573
10574 begin
10575 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
10576 return Has_Tagged_Component (Underlying_Type (Typ));
10577
10578 elsif Is_Array_Type (Typ) then
10579 return Has_Tagged_Component (Component_Type (Typ));
10580
10581 elsif Is_Tagged_Type (Typ) then
10582 return True;
10583
10584 elsif Is_Record_Type (Typ) then
10585 Comp := First_Component (Typ);
10586 while Present (Comp) loop
10587 if Has_Tagged_Component (Etype (Comp)) then
10588 return True;
10589 end if;
10590
10591 Next_Component (Comp);
10592 end loop;
10593
10594 return False;
10595
10596 else
10597 return False;
10598 end if;
10599 end Has_Tagged_Component;
10600
10601 -----------------------------
10602 -- Has_Undefined_Reference --
10603 -----------------------------
10604
10605 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is
10606 Has_Undef_Ref : Boolean := False;
10607 -- Flag set when expression Expr contains at least one undefined
10608 -- reference.
10609
10610 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result;
10611 -- Determine whether N denotes a reference and if it does, whether it is
10612 -- undefined.
10613
10614 ----------------------------
10615 -- Is_Undefined_Reference --
10616 ----------------------------
10617
10618 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is
10619 begin
10620 if Is_Entity_Name (N)
10621 and then Present (Entity (N))
10622 and then Entity (N) = Any_Id
10623 then
10624 Has_Undef_Ref := True;
10625 return Abandon;
10626 end if;
10627
10628 return OK;
10629 end Is_Undefined_Reference;
10630
10631 procedure Find_Undefined_References is
10632 new Traverse_Proc (Is_Undefined_Reference);
10633
10634 -- Start of processing for Has_Undefined_Reference
10635
10636 begin
10637 Find_Undefined_References (Expr);
10638
10639 return Has_Undef_Ref;
10640 end Has_Undefined_Reference;
10641
10642 ----------------------------
10643 -- Has_Volatile_Component --
10644 ----------------------------
10645
10646 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
10647 Comp : Entity_Id;
10648
10649 begin
10650 if Has_Volatile_Components (Typ) then
10651 return True;
10652
10653 elsif Is_Array_Type (Typ) then
10654 return Is_Volatile (Component_Type (Typ));
10655
10656 elsif Is_Record_Type (Typ) then
10657 Comp := First_Component (Typ);
10658 while Present (Comp) loop
10659 if Is_Volatile_Object (Comp) then
10660 return True;
10661 end if;
10662
10663 Comp := Next_Component (Comp);
10664 end loop;
10665 end if;
10666
10667 return False;
10668 end Has_Volatile_Component;
10669
10670 -------------------------
10671 -- Implementation_Kind --
10672 -------------------------
10673
10674 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
10675 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
10676 Arg : Node_Id;
10677 begin
10678 pragma Assert (Present (Impl_Prag));
10679 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
10680 return Chars (Get_Pragma_Arg (Arg));
10681 end Implementation_Kind;
10682
10683 --------------------------
10684 -- Implements_Interface --
10685 --------------------------
10686
10687 function Implements_Interface
10688 (Typ_Ent : Entity_Id;
10689 Iface_Ent : Entity_Id;
10690 Exclude_Parents : Boolean := False) return Boolean
10691 is
10692 Ifaces_List : Elist_Id;
10693 Elmt : Elmt_Id;
10694 Iface : Entity_Id := Base_Type (Iface_Ent);
10695 Typ : Entity_Id := Base_Type (Typ_Ent);
10696
10697 begin
10698 if Is_Class_Wide_Type (Typ) then
10699 Typ := Root_Type (Typ);
10700 end if;
10701
10702 if not Has_Interfaces (Typ) then
10703 return False;
10704 end if;
10705
10706 if Is_Class_Wide_Type (Iface) then
10707 Iface := Root_Type (Iface);
10708 end if;
10709
10710 Collect_Interfaces (Typ, Ifaces_List);
10711
10712 Elmt := First_Elmt (Ifaces_List);
10713 while Present (Elmt) loop
10714 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
10715 and then Exclude_Parents
10716 then
10717 null;
10718
10719 elsif Node (Elmt) = Iface then
10720 return True;
10721 end if;
10722
10723 Next_Elmt (Elmt);
10724 end loop;
10725
10726 return False;
10727 end Implements_Interface;
10728
10729 ------------------------------------
10730 -- In_Assertion_Expression_Pragma --
10731 ------------------------------------
10732
10733 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
10734 Par : Node_Id;
10735 Prag : Node_Id := Empty;
10736
10737 begin
10738 -- Climb the parent chain looking for an enclosing pragma
10739
10740 Par := N;
10741 while Present (Par) loop
10742 if Nkind (Par) = N_Pragma then
10743 Prag := Par;
10744 exit;
10745
10746 -- Precondition-like pragmas are expanded into if statements, check
10747 -- the original node instead.
10748
10749 elsif Nkind (Original_Node (Par)) = N_Pragma then
10750 Prag := Original_Node (Par);
10751 exit;
10752
10753 -- The expansion of attribute 'Old generates a constant to capture
10754 -- the result of the prefix. If the parent traversal reaches
10755 -- one of these constants, then the node technically came from a
10756 -- postcondition-like pragma. Note that the Ekind is not tested here
10757 -- because N may be the expression of an object declaration which is
10758 -- currently being analyzed. Such objects carry Ekind of E_Void.
10759
10760 elsif Nkind (Par) = N_Object_Declaration
10761 and then Constant_Present (Par)
10762 and then Stores_Attribute_Old_Prefix (Defining_Entity (Par))
10763 then
10764 return True;
10765
10766 -- Prevent the search from going too far
10767
10768 elsif Is_Body_Or_Package_Declaration (Par) then
10769 return False;
10770 end if;
10771
10772 Par := Parent (Par);
10773 end loop;
10774
10775 return
10776 Present (Prag)
10777 and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag));
10778 end In_Assertion_Expression_Pragma;
10779
10780 -----------------
10781 -- In_Instance --
10782 -----------------
10783
10784 function In_Instance return Boolean is
10785 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
10786 S : Entity_Id;
10787
10788 begin
10789 S := Current_Scope;
10790 while Present (S) and then S /= Standard_Standard loop
10791 if Ekind_In (S, E_Function, E_Package, E_Procedure)
10792 and then Is_Generic_Instance (S)
10793 then
10794 -- A child instance is always compiled in the context of a parent
10795 -- instance. Nevertheless, the actuals are not analyzed in an
10796 -- instance context. We detect this case by examining the current
10797 -- compilation unit, which must be a child instance, and checking
10798 -- that it is not currently on the scope stack.
10799
10800 if Is_Child_Unit (Curr_Unit)
10801 and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
10802 N_Package_Instantiation
10803 and then not In_Open_Scopes (Curr_Unit)
10804 then
10805 return False;
10806 else
10807 return True;
10808 end if;
10809 end if;
10810
10811 S := Scope (S);
10812 end loop;
10813
10814 return False;
10815 end In_Instance;
10816
10817 ----------------------
10818 -- In_Instance_Body --
10819 ----------------------
10820
10821 function In_Instance_Body return Boolean is
10822 S : Entity_Id;
10823
10824 begin
10825 S := Current_Scope;
10826 while Present (S) and then S /= Standard_Standard loop
10827 if Ekind_In (S, E_Function, E_Procedure)
10828 and then Is_Generic_Instance (S)
10829 then
10830 return True;
10831
10832 elsif Ekind (S) = E_Package
10833 and then In_Package_Body (S)
10834 and then Is_Generic_Instance (S)
10835 then
10836 return True;
10837 end if;
10838
10839 S := Scope (S);
10840 end loop;
10841
10842 return False;
10843 end In_Instance_Body;
10844
10845 -----------------------------
10846 -- In_Instance_Not_Visible --
10847 -----------------------------
10848
10849 function In_Instance_Not_Visible return Boolean is
10850 S : Entity_Id;
10851
10852 begin
10853 S := Current_Scope;
10854 while Present (S) and then S /= Standard_Standard loop
10855 if Ekind_In (S, E_Function, E_Procedure)
10856 and then Is_Generic_Instance (S)
10857 then
10858 return True;
10859
10860 elsif Ekind (S) = E_Package
10861 and then (In_Package_Body (S) or else In_Private_Part (S))
10862 and then Is_Generic_Instance (S)
10863 then
10864 return True;
10865 end if;
10866
10867 S := Scope (S);
10868 end loop;
10869
10870 return False;
10871 end In_Instance_Not_Visible;
10872
10873 ------------------------------
10874 -- In_Instance_Visible_Part --
10875 ------------------------------
10876
10877 function In_Instance_Visible_Part return Boolean is
10878 S : Entity_Id;
10879
10880 begin
10881 S := Current_Scope;
10882 while Present (S) and then S /= Standard_Standard loop
10883 if Ekind (S) = E_Package
10884 and then Is_Generic_Instance (S)
10885 and then not In_Package_Body (S)
10886 and then not In_Private_Part (S)
10887 then
10888 return True;
10889 end if;
10890
10891 S := Scope (S);
10892 end loop;
10893
10894 return False;
10895 end In_Instance_Visible_Part;
10896
10897 ---------------------
10898 -- In_Package_Body --
10899 ---------------------
10900
10901 function In_Package_Body return Boolean is
10902 S : Entity_Id;
10903
10904 begin
10905 S := Current_Scope;
10906 while Present (S) and then S /= Standard_Standard loop
10907 if Ekind (S) = E_Package and then In_Package_Body (S) then
10908 return True;
10909 else
10910 S := Scope (S);
10911 end if;
10912 end loop;
10913
10914 return False;
10915 end In_Package_Body;
10916
10917 --------------------------------
10918 -- In_Parameter_Specification --
10919 --------------------------------
10920
10921 function In_Parameter_Specification (N : Node_Id) return Boolean is
10922 PN : Node_Id;
10923
10924 begin
10925 PN := Parent (N);
10926 while Present (PN) loop
10927 if Nkind (PN) = N_Parameter_Specification then
10928 return True;
10929 end if;
10930
10931 PN := Parent (PN);
10932 end loop;
10933
10934 return False;
10935 end In_Parameter_Specification;
10936
10937 --------------------------
10938 -- In_Pragma_Expression --
10939 --------------------------
10940
10941 function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is
10942 P : Node_Id;
10943 begin
10944 P := Parent (N);
10945 loop
10946 if No (P) then
10947 return False;
10948 elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then
10949 return True;
10950 else
10951 P := Parent (P);
10952 end if;
10953 end loop;
10954 end In_Pragma_Expression;
10955
10956 ---------------------------
10957 -- In_Pre_Post_Condition --
10958 ---------------------------
10959
10960 function In_Pre_Post_Condition (N : Node_Id) return Boolean is
10961 Par : Node_Id;
10962 Prag : Node_Id := Empty;
10963 Prag_Id : Pragma_Id;
10964
10965 begin
10966 -- Climb the parent chain looking for an enclosing pragma
10967
10968 Par := N;
10969 while Present (Par) loop
10970 if Nkind (Par) = N_Pragma then
10971 Prag := Par;
10972 exit;
10973
10974 -- Prevent the search from going too far
10975
10976 elsif Is_Body_Or_Package_Declaration (Par) then
10977 exit;
10978 end if;
10979
10980 Par := Parent (Par);
10981 end loop;
10982
10983 if Present (Prag) then
10984 Prag_Id := Get_Pragma_Id (Prag);
10985
10986 return
10987 Prag_Id = Pragma_Post
10988 or else Prag_Id = Pragma_Post_Class
10989 or else Prag_Id = Pragma_Postcondition
10990 or else Prag_Id = Pragma_Pre
10991 or else Prag_Id = Pragma_Pre_Class
10992 or else Prag_Id = Pragma_Precondition;
10993
10994 -- Otherwise the node is not enclosed by a pre/postcondition pragma
10995
10996 else
10997 return False;
10998 end if;
10999 end In_Pre_Post_Condition;
11000
11001 -------------------------------------
11002 -- In_Reverse_Storage_Order_Object --
11003 -------------------------------------
11004
11005 function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
11006 Pref : Node_Id;
11007 Btyp : Entity_Id := Empty;
11008
11009 begin
11010 -- Climb up indexed components
11011
11012 Pref := N;
11013 loop
11014 case Nkind (Pref) is
11015 when N_Selected_Component =>
11016 Pref := Prefix (Pref);
11017 exit;
11018
11019 when N_Indexed_Component =>
11020 Pref := Prefix (Pref);
11021
11022 when others =>
11023 Pref := Empty;
11024 exit;
11025 end case;
11026 end loop;
11027
11028 if Present (Pref) then
11029 Btyp := Base_Type (Etype (Pref));
11030 end if;
11031
11032 return Present (Btyp)
11033 and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
11034 and then Reverse_Storage_Order (Btyp);
11035 end In_Reverse_Storage_Order_Object;
11036
11037 --------------------------------------
11038 -- In_Subprogram_Or_Concurrent_Unit --
11039 --------------------------------------
11040
11041 function In_Subprogram_Or_Concurrent_Unit return Boolean is
11042 E : Entity_Id;
11043 K : Entity_Kind;
11044
11045 begin
11046 -- Use scope chain to check successively outer scopes
11047
11048 E := Current_Scope;
11049 loop
11050 K := Ekind (E);
11051
11052 if K in Subprogram_Kind
11053 or else K in Concurrent_Kind
11054 or else K in Generic_Subprogram_Kind
11055 then
11056 return True;
11057
11058 elsif E = Standard_Standard then
11059 return False;
11060 end if;
11061
11062 E := Scope (E);
11063 end loop;
11064 end In_Subprogram_Or_Concurrent_Unit;
11065
11066 ---------------------
11067 -- In_Visible_Part --
11068 ---------------------
11069
11070 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
11071 begin
11072 return Is_Package_Or_Generic_Package (Scope_Id)
11073 and then In_Open_Scopes (Scope_Id)
11074 and then not In_Package_Body (Scope_Id)
11075 and then not In_Private_Part (Scope_Id);
11076 end In_Visible_Part;
11077
11078 --------------------------------
11079 -- Incomplete_Or_Partial_View --
11080 --------------------------------
11081
11082 function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is
11083 function Inspect_Decls
11084 (Decls : List_Id;
11085 Taft : Boolean := False) return Entity_Id;
11086 -- Check whether a declarative region contains the incomplete or partial
11087 -- view of Id.
11088
11089 -------------------
11090 -- Inspect_Decls --
11091 -------------------
11092
11093 function Inspect_Decls
11094 (Decls : List_Id;
11095 Taft : Boolean := False) return Entity_Id
11096 is
11097 Decl : Node_Id;
11098 Match : Node_Id;
11099
11100 begin
11101 Decl := First (Decls);
11102 while Present (Decl) loop
11103 Match := Empty;
11104
11105 -- The partial view of a Taft-amendment type is an incomplete
11106 -- type.
11107
11108 if Taft then
11109 if Nkind (Decl) = N_Incomplete_Type_Declaration then
11110 Match := Defining_Identifier (Decl);
11111 end if;
11112
11113 -- Otherwise look for a private type whose full view matches the
11114 -- input type. Note that this checks full_type_declaration nodes
11115 -- to account for derivations from a private type where the type
11116 -- declaration hold the partial view and the full view is an
11117 -- itype.
11118
11119 elsif Nkind_In (Decl, N_Full_Type_Declaration,
11120 N_Private_Extension_Declaration,
11121 N_Private_Type_Declaration)
11122 then
11123 Match := Defining_Identifier (Decl);
11124 end if;
11125
11126 -- Guard against unanalyzed entities
11127
11128 if Present (Match)
11129 and then Is_Type (Match)
11130 and then Present (Full_View (Match))
11131 and then Full_View (Match) = Id
11132 then
11133 return Match;
11134 end if;
11135
11136 Next (Decl);
11137 end loop;
11138
11139 return Empty;
11140 end Inspect_Decls;
11141
11142 -- Local variables
11143
11144 Prev : Entity_Id;
11145
11146 -- Start of processing for Incomplete_Or_Partial_View
11147
11148 begin
11149 -- Deferred constant or incomplete type case
11150
11151 Prev := Current_Entity_In_Scope (Id);
11152
11153 if Present (Prev)
11154 and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant)
11155 and then Present (Full_View (Prev))
11156 and then Full_View (Prev) = Id
11157 then
11158 return Prev;
11159 end if;
11160
11161 -- Private or Taft amendment type case
11162
11163 declare
11164 Pkg : constant Entity_Id := Scope (Id);
11165 Pkg_Decl : Node_Id := Pkg;
11166
11167 begin
11168 if Present (Pkg)
11169 and then Ekind_In (Pkg, E_Generic_Package, E_Package)
11170 then
11171 while Nkind (Pkg_Decl) /= N_Package_Specification loop
11172 Pkg_Decl := Parent (Pkg_Decl);
11173 end loop;
11174
11175 -- It is knows that Typ has a private view, look for it in the
11176 -- visible declarations of the enclosing scope. A special case
11177 -- of this is when the two views have been exchanged - the full
11178 -- appears earlier than the private.
11179
11180 if Has_Private_Declaration (Id) then
11181 Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
11182
11183 -- Exchanged view case, look in the private declarations
11184
11185 if No (Prev) then
11186 Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
11187 end if;
11188
11189 return Prev;
11190
11191 -- Otherwise if this is the package body, then Typ is a potential
11192 -- Taft amendment type. The incomplete view should be located in
11193 -- the private declarations of the enclosing scope.
11194
11195 elsif In_Package_Body (Pkg) then
11196 return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
11197 end if;
11198 end if;
11199 end;
11200
11201 -- The type has no incomplete or private view
11202
11203 return Empty;
11204 end Incomplete_Or_Partial_View;
11205
11206 ----------------------------------
11207 -- Indexed_Component_Bit_Offset --
11208 ----------------------------------
11209
11210 function Indexed_Component_Bit_Offset (N : Node_Id) return Uint is
11211 Exp : constant Node_Id := First (Expressions (N));
11212 Typ : constant Entity_Id := Etype (Prefix (N));
11213 Off : constant Uint := Component_Size (Typ);
11214 Ind : Node_Id;
11215
11216 begin
11217 -- Return early if the component size is not known or variable
11218
11219 if Off = No_Uint or else Off < Uint_0 then
11220 return No_Uint;
11221 end if;
11222
11223 -- Deal with the degenerate case of an empty component
11224
11225 if Off = Uint_0 then
11226 return Off;
11227 end if;
11228
11229 -- Check that both the index value and the low bound are known
11230
11231 if not Compile_Time_Known_Value (Exp) then
11232 return No_Uint;
11233 end if;
11234
11235 Ind := First_Index (Typ);
11236 if No (Ind) then
11237 return No_Uint;
11238 end if;
11239
11240 if Nkind (Ind) = N_Subtype_Indication then
11241 Ind := Constraint (Ind);
11242
11243 if Nkind (Ind) = N_Range_Constraint then
11244 Ind := Range_Expression (Ind);
11245 end if;
11246 end if;
11247
11248 if Nkind (Ind) /= N_Range
11249 or else not Compile_Time_Known_Value (Low_Bound (Ind))
11250 then
11251 return No_Uint;
11252 end if;
11253
11254 -- Return the scaled offset
11255
11256 return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind))));
11257 end Indexed_Component_Bit_Offset;
11258
11259 -----------------------------------------
11260 -- Inherit_Default_Init_Cond_Procedure --
11261 -----------------------------------------
11262
11263 procedure Inherit_Default_Init_Cond_Procedure (Typ : Entity_Id) is
11264 Par_Typ : constant Entity_Id := Etype (Typ);
11265
11266 begin
11267 -- A derived type inherits the default initial condition procedure of
11268 -- its parent type.
11269
11270 if No (Default_Init_Cond_Procedure (Typ)) then
11271 Set_Default_Init_Cond_Procedure
11272 (Typ, Default_Init_Cond_Procedure (Par_Typ));
11273 end if;
11274 end Inherit_Default_Init_Cond_Procedure;
11275
11276 ----------------------------
11277 -- Inherit_Rep_Item_Chain --
11278 ----------------------------
11279
11280 procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is
11281 Item : Node_Id;
11282 Next_Item : Node_Id;
11283
11284 begin
11285 -- There are several inheritance scenarios to consider depending on
11286 -- whether both types have rep item chains and whether the destination
11287 -- type already inherits part of the source type's rep item chain.
11288
11289 -- 1) The source type lacks a rep item chain
11290 -- From_Typ ---> Empty
11291 --
11292 -- Typ --------> Item (or Empty)
11293
11294 -- In this case inheritance cannot take place because there are no items
11295 -- to inherit.
11296
11297 -- 2) The destination type lacks a rep item chain
11298 -- From_Typ ---> Item ---> ...
11299 --
11300 -- Typ --------> Empty
11301
11302 -- Inheritance takes place by setting the First_Rep_Item of the
11303 -- destination type to the First_Rep_Item of the source type.
11304 -- From_Typ ---> Item ---> ...
11305 -- ^
11306 -- Typ -----------+
11307
11308 -- 3.1) Both source and destination types have at least one rep item.
11309 -- The destination type does NOT inherit a rep item from the source
11310 -- type.
11311 -- From_Typ ---> Item ---> Item
11312 --
11313 -- Typ --------> Item ---> Item
11314
11315 -- Inheritance takes place by setting the Next_Rep_Item of the last item
11316 -- of the destination type to the First_Rep_Item of the source type.
11317 -- From_Typ -------------------> Item ---> Item
11318 -- ^
11319 -- Typ --------> Item ---> Item --+
11320
11321 -- 3.2) Both source and destination types have at least one rep item.
11322 -- The destination type DOES inherit part of the rep item chain of the
11323 -- source type.
11324 -- From_Typ ---> Item ---> Item ---> Item
11325 -- ^
11326 -- Typ --------> Item ------+
11327
11328 -- This rare case arises when the full view of a private extension must
11329 -- inherit the rep item chain from the full view of its parent type and
11330 -- the full view of the parent type contains extra rep items. Currently
11331 -- only invariants may lead to such form of inheritance.
11332
11333 -- type From_Typ is tagged private
11334 -- with Type_Invariant'Class => Item_2;
11335
11336 -- type Typ is new From_Typ with private
11337 -- with Type_Invariant => Item_4;
11338
11339 -- At this point the rep item chains contain the following items
11340
11341 -- From_Typ -----------> Item_2 ---> Item_3
11342 -- ^
11343 -- Typ --------> Item_4 --+
11344
11345 -- The full views of both types may introduce extra invariants
11346
11347 -- type From_Typ is tagged null record
11348 -- with Type_Invariant => Item_1;
11349
11350 -- type Typ is new From_Typ with null record;
11351
11352 -- The full view of Typ would have to inherit any new rep items added to
11353 -- the full view of From_Typ.
11354
11355 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
11356 -- ^
11357 -- Typ --------> Item_4 --+
11358
11359 -- To achieve this form of inheritance, the destination type must first
11360 -- sever the link between its own rep chain and that of the source type,
11361 -- then inheritance 3.1 takes place.
11362
11363 -- Case 1: The source type lacks a rep item chain
11364
11365 if No (First_Rep_Item (From_Typ)) then
11366 return;
11367
11368 -- Case 2: The destination type lacks a rep item chain
11369
11370 elsif No (First_Rep_Item (Typ)) then
11371 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ));
11372
11373 -- Case 3: Both the source and destination types have at least one rep
11374 -- item. Traverse the rep item chain of the destination type to find the
11375 -- last rep item.
11376
11377 else
11378 Item := Empty;
11379 Next_Item := First_Rep_Item (Typ);
11380 while Present (Next_Item) loop
11381
11382 -- Detect a link between the destination type's rep chain and that
11383 -- of the source type. There are two possibilities:
11384
11385 -- Variant 1
11386 -- Next_Item
11387 -- V
11388 -- From_Typ ---> Item_1 --->
11389 -- ^
11390 -- Typ -----------+
11391 --
11392 -- Item is Empty
11393
11394 -- Variant 2
11395 -- Next_Item
11396 -- V
11397 -- From_Typ ---> Item_1 ---> Item_2 --->
11398 -- ^
11399 -- Typ --------> Item_3 ------+
11400 -- ^
11401 -- Item
11402
11403 if Has_Rep_Item (From_Typ, Next_Item) then
11404 exit;
11405 end if;
11406
11407 Item := Next_Item;
11408 Next_Item := Next_Rep_Item (Next_Item);
11409 end loop;
11410
11411 -- Inherit the source type's rep item chain
11412
11413 if Present (Item) then
11414 Set_Next_Rep_Item (Item, First_Rep_Item (From_Typ));
11415 else
11416 Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ));
11417 end if;
11418 end if;
11419 end Inherit_Rep_Item_Chain;
11420
11421 ---------------------------------
11422 -- Insert_Explicit_Dereference --
11423 ---------------------------------
11424
11425 procedure Insert_Explicit_Dereference (N : Node_Id) is
11426 New_Prefix : constant Node_Id := Relocate_Node (N);
11427 Ent : Entity_Id := Empty;
11428 Pref : Node_Id;
11429 I : Interp_Index;
11430 It : Interp;
11431 T : Entity_Id;
11432
11433 begin
11434 Save_Interps (N, New_Prefix);
11435
11436 Rewrite (N,
11437 Make_Explicit_Dereference (Sloc (Parent (N)),
11438 Prefix => New_Prefix));
11439
11440 Set_Etype (N, Designated_Type (Etype (New_Prefix)));
11441
11442 if Is_Overloaded (New_Prefix) then
11443
11444 -- The dereference is also overloaded, and its interpretations are
11445 -- the designated types of the interpretations of the original node.
11446
11447 Set_Etype (N, Any_Type);
11448
11449 Get_First_Interp (New_Prefix, I, It);
11450 while Present (It.Nam) loop
11451 T := It.Typ;
11452
11453 if Is_Access_Type (T) then
11454 Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
11455 end if;
11456
11457 Get_Next_Interp (I, It);
11458 end loop;
11459
11460 End_Interp_List;
11461
11462 else
11463 -- Prefix is unambiguous: mark the original prefix (which might
11464 -- Come_From_Source) as a reference, since the new (relocated) one
11465 -- won't be taken into account.
11466
11467 if Is_Entity_Name (New_Prefix) then
11468 Ent := Entity (New_Prefix);
11469 Pref := New_Prefix;
11470
11471 -- For a retrieval of a subcomponent of some composite object,
11472 -- retrieve the ultimate entity if there is one.
11473
11474 elsif Nkind_In (New_Prefix, N_Selected_Component,
11475 N_Indexed_Component)
11476 then
11477 Pref := Prefix (New_Prefix);
11478 while Present (Pref)
11479 and then Nkind_In (Pref, N_Selected_Component,
11480 N_Indexed_Component)
11481 loop
11482 Pref := Prefix (Pref);
11483 end loop;
11484
11485 if Present (Pref) and then Is_Entity_Name (Pref) then
11486 Ent := Entity (Pref);
11487 end if;
11488 end if;
11489
11490 -- Place the reference on the entity node
11491
11492 if Present (Ent) then
11493 Generate_Reference (Ent, Pref);
11494 end if;
11495 end if;
11496 end Insert_Explicit_Dereference;
11497
11498 ------------------------------------------
11499 -- Inspect_Deferred_Constant_Completion --
11500 ------------------------------------------
11501
11502 procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
11503 Decl : Node_Id;
11504
11505 begin
11506 Decl := First (Decls);
11507 while Present (Decl) loop
11508
11509 -- Deferred constant signature
11510
11511 if Nkind (Decl) = N_Object_Declaration
11512 and then Constant_Present (Decl)
11513 and then No (Expression (Decl))
11514
11515 -- No need to check internally generated constants
11516
11517 and then Comes_From_Source (Decl)
11518
11519 -- The constant is not completed. A full object declaration or a
11520 -- pragma Import complete a deferred constant.
11521
11522 and then not Has_Completion (Defining_Identifier (Decl))
11523 then
11524 Error_Msg_N
11525 ("constant declaration requires initialization expression",
11526 Defining_Identifier (Decl));
11527 end if;
11528
11529 Decl := Next (Decl);
11530 end loop;
11531 end Inspect_Deferred_Constant_Completion;
11532
11533 -----------------------------
11534 -- Install_Generic_Formals --
11535 -----------------------------
11536
11537 procedure Install_Generic_Formals (Subp_Id : Entity_Id) is
11538 E : Entity_Id;
11539
11540 begin
11541 pragma Assert (Is_Generic_Subprogram (Subp_Id));
11542
11543 E := First_Entity (Subp_Id);
11544 while Present (E) loop
11545 Install_Entity (E);
11546 Next_Entity (E);
11547 end loop;
11548 end Install_Generic_Formals;
11549
11550 -----------------------------
11551 -- Is_Actual_Out_Parameter --
11552 -----------------------------
11553
11554 function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
11555 Formal : Entity_Id;
11556 Call : Node_Id;
11557 begin
11558 Find_Actual (N, Formal, Call);
11559 return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
11560 end Is_Actual_Out_Parameter;
11561
11562 -------------------------
11563 -- Is_Actual_Parameter --
11564 -------------------------
11565
11566 function Is_Actual_Parameter (N : Node_Id) return Boolean is
11567 PK : constant Node_Kind := Nkind (Parent (N));
11568
11569 begin
11570 case PK is
11571 when N_Parameter_Association =>
11572 return N = Explicit_Actual_Parameter (Parent (N));
11573
11574 when N_Subprogram_Call =>
11575 return Is_List_Member (N)
11576 and then
11577 List_Containing (N) = Parameter_Associations (Parent (N));
11578
11579 when others =>
11580 return False;
11581 end case;
11582 end Is_Actual_Parameter;
11583
11584 --------------------------------
11585 -- Is_Actual_Tagged_Parameter --
11586 --------------------------------
11587
11588 function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
11589 Formal : Entity_Id;
11590 Call : Node_Id;
11591 begin
11592 Find_Actual (N, Formal, Call);
11593 return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
11594 end Is_Actual_Tagged_Parameter;
11595
11596 ---------------------
11597 -- Is_Aliased_View --
11598 ---------------------
11599
11600 function Is_Aliased_View (Obj : Node_Id) return Boolean is
11601 E : Entity_Id;
11602
11603 begin
11604 if Is_Entity_Name (Obj) then
11605 E := Entity (Obj);
11606
11607 return
11608 (Is_Object (E)
11609 and then
11610 (Is_Aliased (E)
11611 or else (Present (Renamed_Object (E))
11612 and then Is_Aliased_View (Renamed_Object (E)))))
11613
11614 or else ((Is_Formal (E)
11615 or else Ekind_In (E, E_Generic_In_Out_Parameter,
11616 E_Generic_In_Parameter))
11617 and then Is_Tagged_Type (Etype (E)))
11618
11619 or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
11620
11621 -- Current instance of type, either directly or as rewritten
11622 -- reference to the current object.
11623
11624 or else (Is_Entity_Name (Original_Node (Obj))
11625 and then Present (Entity (Original_Node (Obj)))
11626 and then Is_Type (Entity (Original_Node (Obj))))
11627
11628 or else (Is_Type (E) and then E = Current_Scope)
11629
11630 or else (Is_Incomplete_Or_Private_Type (E)
11631 and then Full_View (E) = Current_Scope)
11632
11633 -- Ada 2012 AI05-0053: the return object of an extended return
11634 -- statement is aliased if its type is immutably limited.
11635
11636 or else (Is_Return_Object (E)
11637 and then Is_Limited_View (Etype (E)));
11638
11639 elsif Nkind (Obj) = N_Selected_Component then
11640 return Is_Aliased (Entity (Selector_Name (Obj)));
11641
11642 elsif Nkind (Obj) = N_Indexed_Component then
11643 return Has_Aliased_Components (Etype (Prefix (Obj)))
11644 or else
11645 (Is_Access_Type (Etype (Prefix (Obj)))
11646 and then Has_Aliased_Components
11647 (Designated_Type (Etype (Prefix (Obj)))));
11648
11649 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
11650 return Is_Tagged_Type (Etype (Obj))
11651 and then Is_Aliased_View (Expression (Obj));
11652
11653 elsif Nkind (Obj) = N_Explicit_Dereference then
11654 return Nkind (Original_Node (Obj)) /= N_Function_Call;
11655
11656 else
11657 return False;
11658 end if;
11659 end Is_Aliased_View;
11660
11661 -------------------------
11662 -- Is_Ancestor_Package --
11663 -------------------------
11664
11665 function Is_Ancestor_Package
11666 (E1 : Entity_Id;
11667 E2 : Entity_Id) return Boolean
11668 is
11669 Par : Entity_Id;
11670
11671 begin
11672 Par := E2;
11673 while Present (Par) and then Par /= Standard_Standard loop
11674 if Par = E1 then
11675 return True;
11676 end if;
11677
11678 Par := Scope (Par);
11679 end loop;
11680
11681 return False;
11682 end Is_Ancestor_Package;
11683
11684 ----------------------
11685 -- Is_Atomic_Object --
11686 ----------------------
11687
11688 function Is_Atomic_Object (N : Node_Id) return Boolean is
11689
11690 function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
11691 -- Determines if given object has atomic components
11692
11693 function Is_Atomic_Prefix (N : Node_Id) return Boolean;
11694 -- If prefix is an implicit dereference, examine designated type
11695
11696 ----------------------
11697 -- Is_Atomic_Prefix --
11698 ----------------------
11699
11700 function Is_Atomic_Prefix (N : Node_Id) return Boolean is
11701 begin
11702 if Is_Access_Type (Etype (N)) then
11703 return
11704 Has_Atomic_Components (Designated_Type (Etype (N)));
11705 else
11706 return Object_Has_Atomic_Components (N);
11707 end if;
11708 end Is_Atomic_Prefix;
11709
11710 ----------------------------------
11711 -- Object_Has_Atomic_Components --
11712 ----------------------------------
11713
11714 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
11715 begin
11716 if Has_Atomic_Components (Etype (N))
11717 or else Is_Atomic (Etype (N))
11718 then
11719 return True;
11720
11721 elsif Is_Entity_Name (N)
11722 and then (Has_Atomic_Components (Entity (N))
11723 or else Is_Atomic (Entity (N)))
11724 then
11725 return True;
11726
11727 elsif Nkind (N) = N_Selected_Component
11728 and then Is_Atomic (Entity (Selector_Name (N)))
11729 then
11730 return True;
11731
11732 elsif Nkind (N) = N_Indexed_Component
11733 or else Nkind (N) = N_Selected_Component
11734 then
11735 return Is_Atomic_Prefix (Prefix (N));
11736
11737 else
11738 return False;
11739 end if;
11740 end Object_Has_Atomic_Components;
11741
11742 -- Start of processing for Is_Atomic_Object
11743
11744 begin
11745 -- Predicate is not relevant to subprograms
11746
11747 if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
11748 return False;
11749
11750 elsif Is_Atomic (Etype (N))
11751 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
11752 then
11753 return True;
11754
11755 elsif Nkind (N) = N_Selected_Component
11756 and then Is_Atomic (Entity (Selector_Name (N)))
11757 then
11758 return True;
11759
11760 elsif Nkind (N) = N_Indexed_Component
11761 or else Nkind (N) = N_Selected_Component
11762 then
11763 return Is_Atomic_Prefix (Prefix (N));
11764
11765 else
11766 return False;
11767 end if;
11768 end Is_Atomic_Object;
11769
11770 -----------------------------
11771 -- Is_Atomic_Or_VFA_Object --
11772 -----------------------------
11773
11774 function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is
11775 begin
11776 return Is_Atomic_Object (N)
11777 or else (Is_Object_Reference (N)
11778 and then Is_Entity_Name (N)
11779 and then (Is_Volatile_Full_Access (Entity (N))
11780 or else
11781 Is_Volatile_Full_Access (Etype (Entity (N)))));
11782 end Is_Atomic_Or_VFA_Object;
11783
11784 -------------------------
11785 -- Is_Attribute_Result --
11786 -------------------------
11787
11788 function Is_Attribute_Result (N : Node_Id) return Boolean is
11789 begin
11790 return Nkind (N) = N_Attribute_Reference
11791 and then Attribute_Name (N) = Name_Result;
11792 end Is_Attribute_Result;
11793
11794 -------------------------
11795 -- Is_Attribute_Update --
11796 -------------------------
11797
11798 function Is_Attribute_Update (N : Node_Id) return Boolean is
11799 begin
11800 return Nkind (N) = N_Attribute_Reference
11801 and then Attribute_Name (N) = Name_Update;
11802 end Is_Attribute_Update;
11803
11804 ------------------------------------
11805 -- Is_Body_Or_Package_Declaration --
11806 ------------------------------------
11807
11808 function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is
11809 begin
11810 return Nkind_In (N, N_Entry_Body,
11811 N_Package_Body,
11812 N_Package_Declaration,
11813 N_Protected_Body,
11814 N_Subprogram_Body,
11815 N_Task_Body);
11816 end Is_Body_Or_Package_Declaration;
11817
11818 -----------------------
11819 -- Is_Bounded_String --
11820 -----------------------
11821
11822 function Is_Bounded_String (T : Entity_Id) return Boolean is
11823 Under : constant Entity_Id := Underlying_Type (Root_Type (T));
11824
11825 begin
11826 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
11827 -- Super_String, or one of the [Wide_]Wide_ versions. This will
11828 -- be True for all the Bounded_String types in instances of the
11829 -- Generic_Bounded_Length generics, and for types derived from those.
11830
11831 return Present (Under)
11832 and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else
11833 Is_RTE (Root_Type (Under), RO_WI_Super_String) or else
11834 Is_RTE (Root_Type (Under), RO_WW_Super_String));
11835 end Is_Bounded_String;
11836
11837 -------------------------
11838 -- Is_Child_Or_Sibling --
11839 -------------------------
11840
11841 function Is_Child_Or_Sibling
11842 (Pack_1 : Entity_Id;
11843 Pack_2 : Entity_Id) return Boolean
11844 is
11845 function Distance_From_Standard (Pack : Entity_Id) return Nat;
11846 -- Given an arbitrary package, return the number of "climbs" necessary
11847 -- to reach scope Standard_Standard.
11848
11849 procedure Equalize_Depths
11850 (Pack : in out Entity_Id;
11851 Depth : in out Nat;
11852 Depth_To_Reach : Nat);
11853 -- Given an arbitrary package, its depth and a target depth to reach,
11854 -- climb the scope chain until the said depth is reached. The pointer
11855 -- to the package and its depth a modified during the climb.
11856
11857 ----------------------------
11858 -- Distance_From_Standard --
11859 ----------------------------
11860
11861 function Distance_From_Standard (Pack : Entity_Id) return Nat is
11862 Dist : Nat;
11863 Scop : Entity_Id;
11864
11865 begin
11866 Dist := 0;
11867 Scop := Pack;
11868 while Present (Scop) and then Scop /= Standard_Standard loop
11869 Dist := Dist + 1;
11870 Scop := Scope (Scop);
11871 end loop;
11872
11873 return Dist;
11874 end Distance_From_Standard;
11875
11876 ---------------------
11877 -- Equalize_Depths --
11878 ---------------------
11879
11880 procedure Equalize_Depths
11881 (Pack : in out Entity_Id;
11882 Depth : in out Nat;
11883 Depth_To_Reach : Nat)
11884 is
11885 begin
11886 -- The package must be at a greater or equal depth
11887
11888 if Depth < Depth_To_Reach then
11889 raise Program_Error;
11890 end if;
11891
11892 -- Climb the scope chain until the desired depth is reached
11893
11894 while Present (Pack) and then Depth /= Depth_To_Reach loop
11895 Pack := Scope (Pack);
11896 Depth := Depth - 1;
11897 end loop;
11898 end Equalize_Depths;
11899
11900 -- Local variables
11901
11902 P_1 : Entity_Id := Pack_1;
11903 P_1_Child : Boolean := False;
11904 P_1_Depth : Nat := Distance_From_Standard (P_1);
11905 P_2 : Entity_Id := Pack_2;
11906 P_2_Child : Boolean := False;
11907 P_2_Depth : Nat := Distance_From_Standard (P_2);
11908
11909 -- Start of processing for Is_Child_Or_Sibling
11910
11911 begin
11912 pragma Assert
11913 (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package);
11914
11915 -- Both packages denote the same entity, therefore they cannot be
11916 -- children or siblings.
11917
11918 if P_1 = P_2 then
11919 return False;
11920
11921 -- One of the packages is at a deeper level than the other. Note that
11922 -- both may still come from differen hierarchies.
11923
11924 -- (root) P_2
11925 -- / \ :
11926 -- X P_2 or X
11927 -- : :
11928 -- P_1 P_1
11929
11930 elsif P_1_Depth > P_2_Depth then
11931 Equalize_Depths
11932 (Pack => P_1,
11933 Depth => P_1_Depth,
11934 Depth_To_Reach => P_2_Depth);
11935 P_1_Child := True;
11936
11937 -- (root) P_1
11938 -- / \ :
11939 -- P_1 X or X
11940 -- : :
11941 -- P_2 P_2
11942
11943 elsif P_2_Depth > P_1_Depth then
11944 Equalize_Depths
11945 (Pack => P_2,
11946 Depth => P_2_Depth,
11947 Depth_To_Reach => P_1_Depth);
11948 P_2_Child := True;
11949 end if;
11950
11951 -- At this stage the package pointers have been elevated to the same
11952 -- depth. If the related entities are the same, then one package is a
11953 -- potential child of the other:
11954
11955 -- P_1
11956 -- :
11957 -- X became P_1 P_2 or vica versa
11958 -- :
11959 -- P_2
11960
11961 if P_1 = P_2 then
11962 if P_1_Child then
11963 return Is_Child_Unit (Pack_1);
11964
11965 else pragma Assert (P_2_Child);
11966 return Is_Child_Unit (Pack_2);
11967 end if;
11968
11969 -- The packages may come from the same package chain or from entirely
11970 -- different hierarcies. To determine this, climb the scope stack until
11971 -- a common root is found.
11972
11973 -- (root) (root 1) (root 2)
11974 -- / \ | |
11975 -- P_1 P_2 P_1 P_2
11976
11977 else
11978 while Present (P_1) and then Present (P_2) loop
11979
11980 -- The two packages may be siblings
11981
11982 if P_1 = P_2 then
11983 return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2);
11984 end if;
11985
11986 P_1 := Scope (P_1);
11987 P_2 := Scope (P_2);
11988 end loop;
11989 end if;
11990
11991 return False;
11992 end Is_Child_Or_Sibling;
11993
11994 -----------------------------
11995 -- Is_Concurrent_Interface --
11996 -----------------------------
11997
11998 function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
11999 begin
12000 return Is_Interface (T)
12001 and then
12002 (Is_Protected_Interface (T)
12003 or else Is_Synchronized_Interface (T)
12004 or else Is_Task_Interface (T));
12005 end Is_Concurrent_Interface;
12006
12007 -----------------------
12008 -- Is_Constant_Bound --
12009 -----------------------
12010
12011 function Is_Constant_Bound (Exp : Node_Id) return Boolean is
12012 begin
12013 if Compile_Time_Known_Value (Exp) then
12014 return True;
12015
12016 elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
12017 return Is_Constant_Object (Entity (Exp))
12018 or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
12019
12020 elsif Nkind (Exp) in N_Binary_Op then
12021 return Is_Constant_Bound (Left_Opnd (Exp))
12022 and then Is_Constant_Bound (Right_Opnd (Exp))
12023 and then Scope (Entity (Exp)) = Standard_Standard;
12024
12025 else
12026 return False;
12027 end if;
12028 end Is_Constant_Bound;
12029
12030 ---------------------------
12031 -- Is_Container_Element --
12032 ---------------------------
12033
12034 function Is_Container_Element (Exp : Node_Id) return Boolean is
12035 Loc : constant Source_Ptr := Sloc (Exp);
12036 Pref : constant Node_Id := Prefix (Exp);
12037
12038 Call : Node_Id;
12039 -- Call to an indexing aspect
12040
12041 Cont_Typ : Entity_Id;
12042 -- The type of the container being accessed
12043
12044 Elem_Typ : Entity_Id;
12045 -- Its element type
12046
12047 Indexing : Entity_Id;
12048 Is_Const : Boolean;
12049 -- Indicates that constant indexing is used, and the element is thus
12050 -- a constant.
12051
12052 Ref_Typ : Entity_Id;
12053 -- The reference type returned by the indexing operation
12054
12055 begin
12056 -- If C is a container, in a context that imposes the element type of
12057 -- that container, the indexing notation C (X) is rewritten as:
12058
12059 -- Indexing (C, X).Discr.all
12060
12061 -- where Indexing is one of the indexing aspects of the container.
12062 -- If the context does not require a reference, the construct can be
12063 -- rewritten as
12064
12065 -- Element (C, X)
12066
12067 -- First, verify that the construct has the proper form
12068
12069 if not Expander_Active then
12070 return False;
12071
12072 elsif Nkind (Pref) /= N_Selected_Component then
12073 return False;
12074
12075 elsif Nkind (Prefix (Pref)) /= N_Function_Call then
12076 return False;
12077
12078 else
12079 Call := Prefix (Pref);
12080 Ref_Typ := Etype (Call);
12081 end if;
12082
12083 if not Has_Implicit_Dereference (Ref_Typ)
12084 or else No (First (Parameter_Associations (Call)))
12085 or else not Is_Entity_Name (Name (Call))
12086 then
12087 return False;
12088 end if;
12089
12090 -- Retrieve type of container object, and its iterator aspects
12091
12092 Cont_Typ := Etype (First (Parameter_Associations (Call)));
12093 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing);
12094 Is_Const := False;
12095
12096 if No (Indexing) then
12097
12098 -- Container should have at least one indexing operation
12099
12100 return False;
12101
12102 elsif Entity (Name (Call)) /= Entity (Indexing) then
12103
12104 -- This may be a variable indexing operation
12105
12106 Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing);
12107
12108 if No (Indexing)
12109 or else Entity (Name (Call)) /= Entity (Indexing)
12110 then
12111 return False;
12112 end if;
12113
12114 else
12115 Is_Const := True;
12116 end if;
12117
12118 Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element);
12119
12120 if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then
12121 return False;
12122 end if;
12123
12124 -- Check that the expression is not the target of an assignment, in
12125 -- which case the rewriting is not possible.
12126
12127 if not Is_Const then
12128 declare
12129 Par : Node_Id;
12130
12131 begin
12132 Par := Exp;
12133 while Present (Par)
12134 loop
12135 if Nkind (Parent (Par)) = N_Assignment_Statement
12136 and then Par = Name (Parent (Par))
12137 then
12138 return False;
12139
12140 -- A renaming produces a reference, and the transformation
12141 -- does not apply.
12142
12143 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
12144 return False;
12145
12146 elsif Nkind_In
12147 (Nkind (Parent (Par)), N_Function_Call,
12148 N_Procedure_Call_Statement,
12149 N_Entry_Call_Statement)
12150 then
12151 -- Check that the element is not part of an actual for an
12152 -- in-out parameter.
12153
12154 declare
12155 F : Entity_Id;
12156 A : Node_Id;
12157
12158 begin
12159 F := First_Formal (Entity (Name (Parent (Par))));
12160 A := First (Parameter_Associations (Parent (Par)));
12161 while Present (F) loop
12162 if A = Par and then Ekind (F) /= E_In_Parameter then
12163 return False;
12164 end if;
12165
12166 Next_Formal (F);
12167 Next (A);
12168 end loop;
12169 end;
12170
12171 -- E_In_Parameter in a call: element is not modified.
12172
12173 exit;
12174 end if;
12175
12176 Par := Parent (Par);
12177 end loop;
12178 end;
12179 end if;
12180
12181 -- The expression has the proper form and the context requires the
12182 -- element type. Retrieve the Element function of the container and
12183 -- rewrite the construct as a call to it.
12184
12185 declare
12186 Op : Elmt_Id;
12187
12188 begin
12189 Op := First_Elmt (Primitive_Operations (Cont_Typ));
12190 while Present (Op) loop
12191 exit when Chars (Node (Op)) = Name_Element;
12192 Next_Elmt (Op);
12193 end loop;
12194
12195 if No (Op) then
12196 return False;
12197
12198 else
12199 Rewrite (Exp,
12200 Make_Function_Call (Loc,
12201 Name => New_Occurrence_Of (Node (Op), Loc),
12202 Parameter_Associations => Parameter_Associations (Call)));
12203 Analyze_And_Resolve (Exp, Entity (Elem_Typ));
12204 return True;
12205 end if;
12206 end;
12207 end Is_Container_Element;
12208
12209 ----------------------------
12210 -- Is_Contract_Annotation --
12211 ----------------------------
12212
12213 function Is_Contract_Annotation (Item : Node_Id) return Boolean is
12214 begin
12215 return Is_Package_Contract_Annotation (Item)
12216 or else
12217 Is_Subprogram_Contract_Annotation (Item);
12218 end Is_Contract_Annotation;
12219
12220 --------------------------------------
12221 -- Is_Controlling_Limited_Procedure --
12222 --------------------------------------
12223
12224 function Is_Controlling_Limited_Procedure
12225 (Proc_Nam : Entity_Id) return Boolean
12226 is
12227 Param_Typ : Entity_Id := Empty;
12228
12229 begin
12230 if Ekind (Proc_Nam) = E_Procedure
12231 and then Present (Parameter_Specifications (Parent (Proc_Nam)))
12232 then
12233 Param_Typ := Etype (Parameter_Type (First (
12234 Parameter_Specifications (Parent (Proc_Nam)))));
12235
12236 -- In this case where an Itype was created, the procedure call has been
12237 -- rewritten.
12238
12239 elsif Present (Associated_Node_For_Itype (Proc_Nam))
12240 and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
12241 and then
12242 Present (Parameter_Associations
12243 (Associated_Node_For_Itype (Proc_Nam)))
12244 then
12245 Param_Typ :=
12246 Etype (First (Parameter_Associations
12247 (Associated_Node_For_Itype (Proc_Nam))));
12248 end if;
12249
12250 if Present (Param_Typ) then
12251 return
12252 Is_Interface (Param_Typ)
12253 and then Is_Limited_Record (Param_Typ);
12254 end if;
12255
12256 return False;
12257 end Is_Controlling_Limited_Procedure;
12258
12259 -----------------------------
12260 -- Is_CPP_Constructor_Call --
12261 -----------------------------
12262
12263 function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
12264 begin
12265 return Nkind (N) = N_Function_Call
12266 and then Is_CPP_Class (Etype (Etype (N)))
12267 and then Is_Constructor (Entity (Name (N)))
12268 and then Is_Imported (Entity (Name (N)));
12269 end Is_CPP_Constructor_Call;
12270
12271 -------------------------
12272 -- Is_Current_Instance --
12273 -------------------------
12274
12275 function Is_Current_Instance (N : Node_Id) return Boolean is
12276 Typ : constant Entity_Id := Entity (N);
12277 P : Node_Id;
12278
12279 begin
12280 -- Simplest case: entity is a concurrent type and we are currently
12281 -- inside the body. This will eventually be expanded into a
12282 -- call to Self (for tasks) or _object (for protected objects).
12283
12284 if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then
12285 return True;
12286
12287 else
12288 -- Check whether the context is a (sub)type declaration for the
12289 -- type entity.
12290
12291 P := Parent (N);
12292 while Present (P) loop
12293 if Nkind_In (P, N_Full_Type_Declaration,
12294 N_Private_Type_Declaration,
12295 N_Subtype_Declaration)
12296 and then Comes_From_Source (P)
12297 and then Defining_Entity (P) = Typ
12298 then
12299 return True;
12300
12301 -- A subtype name may appear in an aspect specification for a
12302 -- Predicate_Failure aspect, for which we do not construct a
12303 -- wrapper procedure. The subtype will be replaced by the
12304 -- expression being tested when the corresponding predicate
12305 -- check is expanded.
12306
12307 elsif Nkind (P) = N_Aspect_Specification
12308 and then Nkind (Parent (P)) = N_Subtype_Declaration
12309 then
12310 return True;
12311
12312 elsif Nkind (P) = N_Pragma
12313 and then
12314 Get_Pragma_Id (Pragma_Name (P)) = Pragma_Predicate_Failure
12315 then
12316 return True;
12317 end if;
12318
12319 P := Parent (P);
12320 end loop;
12321 end if;
12322
12323 -- In any other context this is not a current occurrence
12324
12325 return False;
12326 end Is_Current_Instance;
12327
12328 --------------------
12329 -- Is_Declaration --
12330 --------------------
12331
12332 function Is_Declaration (N : Node_Id) return Boolean is
12333 begin
12334 case Nkind (N) is
12335 when N_Abstract_Subprogram_Declaration |
12336 N_Exception_Declaration |
12337 N_Exception_Renaming_Declaration |
12338 N_Full_Type_Declaration |
12339 N_Generic_Function_Renaming_Declaration |
12340 N_Generic_Package_Declaration |
12341 N_Generic_Package_Renaming_Declaration |
12342 N_Generic_Procedure_Renaming_Declaration |
12343 N_Generic_Subprogram_Declaration |
12344 N_Number_Declaration |
12345 N_Object_Declaration |
12346 N_Object_Renaming_Declaration |
12347 N_Package_Declaration |
12348 N_Package_Renaming_Declaration |
12349 N_Private_Extension_Declaration |
12350 N_Private_Type_Declaration |
12351 N_Subprogram_Declaration |
12352 N_Subprogram_Renaming_Declaration |
12353 N_Subtype_Declaration =>
12354 return True;
12355
12356 when others =>
12357 return False;
12358 end case;
12359 end Is_Declaration;
12360
12361 --------------------------------
12362 -- Is_Declared_Within_Variant --
12363 --------------------------------
12364
12365 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
12366 Comp_Decl : constant Node_Id := Parent (Comp);
12367 Comp_List : constant Node_Id := Parent (Comp_Decl);
12368 begin
12369 return Nkind (Parent (Comp_List)) = N_Variant;
12370 end Is_Declared_Within_Variant;
12371
12372 ----------------------------------------------
12373 -- Is_Dependent_Component_Of_Mutable_Object --
12374 ----------------------------------------------
12375
12376 function Is_Dependent_Component_Of_Mutable_Object
12377 (Object : Node_Id) return Boolean
12378 is
12379 P : Node_Id;
12380 Prefix_Type : Entity_Id;
12381 P_Aliased : Boolean := False;
12382 Comp : Entity_Id;
12383
12384 Deref : Node_Id := Object;
12385 -- Dereference node, in something like X.all.Y(2)
12386
12387 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
12388
12389 begin
12390 -- Find the dereference node if any
12391
12392 while Nkind_In (Deref, N_Indexed_Component,
12393 N_Selected_Component,
12394 N_Slice)
12395 loop
12396 Deref := Prefix (Deref);
12397 end loop;
12398
12399 -- Ada 2005: If we have a component or slice of a dereference,
12400 -- something like X.all.Y (2), and the type of X is access-to-constant,
12401 -- Is_Variable will return False, because it is indeed a constant
12402 -- view. But it might be a view of a variable object, so we want the
12403 -- following condition to be True in that case.
12404
12405 if Is_Variable (Object)
12406 or else (Ada_Version >= Ada_2005
12407 and then Nkind (Deref) = N_Explicit_Dereference)
12408 then
12409 if Nkind (Object) = N_Selected_Component then
12410 P := Prefix (Object);
12411 Prefix_Type := Etype (P);
12412
12413 if Is_Entity_Name (P) then
12414 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
12415 Prefix_Type := Base_Type (Prefix_Type);
12416 end if;
12417
12418 if Is_Aliased (Entity (P)) then
12419 P_Aliased := True;
12420 end if;
12421
12422 -- A discriminant check on a selected component may be expanded
12423 -- into a dereference when removing side-effects. Recover the
12424 -- original node and its type, which may be unconstrained.
12425
12426 elsif Nkind (P) = N_Explicit_Dereference
12427 and then not (Comes_From_Source (P))
12428 then
12429 P := Original_Node (P);
12430 Prefix_Type := Etype (P);
12431
12432 else
12433 -- Check for prefix being an aliased component???
12434
12435 null;
12436
12437 end if;
12438
12439 -- A heap object is constrained by its initial value
12440
12441 -- Ada 2005 (AI-363): Always assume the object could be mutable in
12442 -- the dereferenced case, since the access value might denote an
12443 -- unconstrained aliased object, whereas in Ada 95 the designated
12444 -- object is guaranteed to be constrained. A worst-case assumption
12445 -- has to apply in Ada 2005 because we can't tell at compile
12446 -- time whether the object is "constrained by its initial value"
12447 -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
12448 -- rules (these rules are acknowledged to need fixing).
12449
12450 if Ada_Version < Ada_2005 then
12451 if Is_Access_Type (Prefix_Type)
12452 or else Nkind (P) = N_Explicit_Dereference
12453 then
12454 return False;
12455 end if;
12456
12457 else pragma Assert (Ada_Version >= Ada_2005);
12458 if Is_Access_Type (Prefix_Type) then
12459
12460 -- If the access type is pool-specific, and there is no
12461 -- constrained partial view of the designated type, then the
12462 -- designated object is known to be constrained.
12463
12464 if Ekind (Prefix_Type) = E_Access_Type
12465 and then not Object_Type_Has_Constrained_Partial_View
12466 (Typ => Designated_Type (Prefix_Type),
12467 Scop => Current_Scope)
12468 then
12469 return False;
12470
12471 -- Otherwise (general access type, or there is a constrained
12472 -- partial view of the designated type), we need to check
12473 -- based on the designated type.
12474
12475 else
12476 Prefix_Type := Designated_Type (Prefix_Type);
12477 end if;
12478 end if;
12479 end if;
12480
12481 Comp :=
12482 Original_Record_Component (Entity (Selector_Name (Object)));
12483
12484 -- As per AI-0017, the renaming is illegal in a generic body, even
12485 -- if the subtype is indefinite.
12486
12487 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
12488
12489 if not Is_Constrained (Prefix_Type)
12490 and then (Is_Definite_Subtype (Prefix_Type)
12491 or else
12492 (Is_Generic_Type (Prefix_Type)
12493 and then Ekind (Current_Scope) = E_Generic_Package
12494 and then In_Package_Body (Current_Scope)))
12495
12496 and then (Is_Declared_Within_Variant (Comp)
12497 or else Has_Discriminant_Dependent_Constraint (Comp))
12498 and then (not P_Aliased or else Ada_Version >= Ada_2005)
12499 then
12500 return True;
12501
12502 -- If the prefix is of an access type at this point, then we want
12503 -- to return False, rather than calling this function recursively
12504 -- on the access object (which itself might be a discriminant-
12505 -- dependent component of some other object, but that isn't
12506 -- relevant to checking the object passed to us). This avoids
12507 -- issuing wrong errors when compiling with -gnatc, where there
12508 -- can be implicit dereferences that have not been expanded.
12509
12510 elsif Is_Access_Type (Etype (Prefix (Object))) then
12511 return False;
12512
12513 else
12514 return
12515 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
12516 end if;
12517
12518 elsif Nkind (Object) = N_Indexed_Component
12519 or else Nkind (Object) = N_Slice
12520 then
12521 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
12522
12523 -- A type conversion that Is_Variable is a view conversion:
12524 -- go back to the denoted object.
12525
12526 elsif Nkind (Object) = N_Type_Conversion then
12527 return
12528 Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
12529 end if;
12530 end if;
12531
12532 return False;
12533 end Is_Dependent_Component_Of_Mutable_Object;
12534
12535 ---------------------
12536 -- Is_Dereferenced --
12537 ---------------------
12538
12539 function Is_Dereferenced (N : Node_Id) return Boolean is
12540 P : constant Node_Id := Parent (N);
12541 begin
12542 return Nkind_In (P, N_Selected_Component,
12543 N_Explicit_Dereference,
12544 N_Indexed_Component,
12545 N_Slice)
12546 and then Prefix (P) = N;
12547 end Is_Dereferenced;
12548
12549 ----------------------
12550 -- Is_Descendant_Of --
12551 ----------------------
12552
12553 function Is_Descendant_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
12554 T : Entity_Id;
12555 Etyp : Entity_Id;
12556
12557 begin
12558 pragma Assert (Nkind (T1) in N_Entity);
12559 pragma Assert (Nkind (T2) in N_Entity);
12560
12561 T := Base_Type (T1);
12562
12563 -- Immediate return if the types match
12564
12565 if T = T2 then
12566 return True;
12567
12568 -- Comment needed here ???
12569
12570 elsif Ekind (T) = E_Class_Wide_Type then
12571 return Etype (T) = T2;
12572
12573 -- All other cases
12574
12575 else
12576 loop
12577 Etyp := Etype (T);
12578
12579 -- Done if we found the type we are looking for
12580
12581 if Etyp = T2 then
12582 return True;
12583
12584 -- Done if no more derivations to check
12585
12586 elsif T = T1
12587 or else T = Etyp
12588 then
12589 return False;
12590
12591 -- Following test catches error cases resulting from prev errors
12592
12593 elsif No (Etyp) then
12594 return False;
12595
12596 elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
12597 return False;
12598
12599 elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
12600 return False;
12601 end if;
12602
12603 T := Base_Type (Etyp);
12604 end loop;
12605 end if;
12606 end Is_Descendant_Of;
12607
12608 ----------------------------------------
12609 -- Is_Descendant_Of_Suspension_Object --
12610 ----------------------------------------
12611
12612 function Is_Descendant_Of_Suspension_Object
12613 (Typ : Entity_Id) return Boolean
12614 is
12615 Cur_Typ : Entity_Id;
12616 Par_Typ : Entity_Id;
12617
12618 begin
12619 -- Climb the type derivation chain checking each parent type against
12620 -- Suspension_Object.
12621
12622 Cur_Typ := Base_Type (Typ);
12623 while Present (Cur_Typ) loop
12624 Par_Typ := Etype (Cur_Typ);
12625
12626 -- The current type is a match
12627
12628 if Is_Suspension_Object (Cur_Typ) then
12629 return True;
12630
12631 -- Stop the traversal once the root of the derivation chain has been
12632 -- reached. In that case the current type is its own base type.
12633
12634 elsif Cur_Typ = Par_Typ then
12635 exit;
12636 end if;
12637
12638 Cur_Typ := Base_Type (Par_Typ);
12639 end loop;
12640
12641 return False;
12642 end Is_Descendant_Of_Suspension_Object;
12643
12644 ---------------------------------------------
12645 -- Is_Double_Precision_Floating_Point_Type --
12646 ---------------------------------------------
12647
12648 function Is_Double_Precision_Floating_Point_Type
12649 (E : Entity_Id) return Boolean is
12650 begin
12651 return Is_Floating_Point_Type (E)
12652 and then Machine_Radix_Value (E) = Uint_2
12653 and then Machine_Mantissa_Value (E) = UI_From_Int (53)
12654 and then Machine_Emax_Value (E) = Uint_2 ** Uint_10
12655 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_10);
12656 end Is_Double_Precision_Floating_Point_Type;
12657
12658 -----------------------------
12659 -- Is_Effectively_Volatile --
12660 -----------------------------
12661
12662 function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is
12663 begin
12664 if Is_Type (Id) then
12665
12666 -- An arbitrary type is effectively volatile when it is subject to
12667 -- pragma Atomic or Volatile.
12668
12669 if Is_Volatile (Id) then
12670 return True;
12671
12672 -- An array type is effectively volatile when it is subject to pragma
12673 -- Atomic_Components or Volatile_Components or its component type is
12674 -- effectively volatile.
12675
12676 elsif Is_Array_Type (Id) then
12677 return
12678 Has_Volatile_Components (Id)
12679 or else
12680 Is_Effectively_Volatile (Component_Type (Base_Type (Id)));
12681
12682 -- A protected type is always volatile
12683
12684 elsif Is_Protected_Type (Id) then
12685 return True;
12686
12687 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
12688 -- automatically volatile.
12689
12690 elsif Is_Descendant_Of_Suspension_Object (Id) then
12691 return True;
12692
12693 -- Otherwise the type is not effectively volatile
12694
12695 else
12696 return False;
12697 end if;
12698
12699 -- Otherwise Id denotes an object
12700
12701 else
12702 return
12703 Is_Volatile (Id)
12704 or else Has_Volatile_Components (Id)
12705 or else Is_Effectively_Volatile (Etype (Id));
12706 end if;
12707 end Is_Effectively_Volatile;
12708
12709 ------------------------------------
12710 -- Is_Effectively_Volatile_Object --
12711 ------------------------------------
12712
12713 function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is
12714 begin
12715 if Is_Entity_Name (N) then
12716 return Is_Effectively_Volatile (Entity (N));
12717
12718 elsif Nkind (N) = N_Indexed_Component then
12719 return Is_Effectively_Volatile_Object (Prefix (N));
12720
12721 elsif Nkind (N) = N_Selected_Component then
12722 return
12723 Is_Effectively_Volatile_Object (Prefix (N))
12724 or else
12725 Is_Effectively_Volatile_Object (Selector_Name (N));
12726
12727 else
12728 return False;
12729 end if;
12730 end Is_Effectively_Volatile_Object;
12731
12732 -------------------
12733 -- Is_Entry_Body --
12734 -------------------
12735
12736 function Is_Entry_Body (Id : Entity_Id) return Boolean is
12737 begin
12738 return
12739 Ekind_In (Id, E_Entry, E_Entry_Family)
12740 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body;
12741 end Is_Entry_Body;
12742
12743 --------------------------
12744 -- Is_Entry_Declaration --
12745 --------------------------
12746
12747 function Is_Entry_Declaration (Id : Entity_Id) return Boolean is
12748 begin
12749 return
12750 Ekind_In (Id, E_Entry, E_Entry_Family)
12751 and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration;
12752 end Is_Entry_Declaration;
12753
12754 ------------------------------------
12755 -- Is_Expanded_Priority_Attribute --
12756 ------------------------------------
12757
12758 function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean is
12759 begin
12760 return
12761 Nkind (E) = N_Function_Call
12762 and then not Configurable_Run_Time_Mode
12763 and then (Entity (Name (E)) = RTE (RE_Get_Ceiling)
12764 or else Entity (Name (E)) = RTE (RO_PE_Get_Ceiling));
12765 end Is_Expanded_Priority_Attribute;
12766
12767 ----------------------------
12768 -- Is_Expression_Function --
12769 ----------------------------
12770
12771 function Is_Expression_Function (Subp : Entity_Id) return Boolean is
12772 begin
12773 if Ekind_In (Subp, E_Function, E_Subprogram_Body) then
12774 return
12775 Nkind (Original_Node (Unit_Declaration_Node (Subp))) =
12776 N_Expression_Function;
12777 else
12778 return False;
12779 end if;
12780 end Is_Expression_Function;
12781
12782 ------------------------------------------
12783 -- Is_Expression_Function_Or_Completion --
12784 ------------------------------------------
12785
12786 function Is_Expression_Function_Or_Completion
12787 (Subp : Entity_Id) return Boolean
12788 is
12789 Subp_Decl : Node_Id;
12790
12791 begin
12792 if Ekind (Subp) = E_Function then
12793 Subp_Decl := Unit_Declaration_Node (Subp);
12794
12795 -- The function declaration is either an expression function or is
12796 -- completed by an expression function body.
12797
12798 return
12799 Is_Expression_Function (Subp)
12800 or else (Nkind (Subp_Decl) = N_Subprogram_Declaration
12801 and then Present (Corresponding_Body (Subp_Decl))
12802 and then Is_Expression_Function
12803 (Corresponding_Body (Subp_Decl)));
12804
12805 elsif Ekind (Subp) = E_Subprogram_Body then
12806 return Is_Expression_Function (Subp);
12807
12808 else
12809 return False;
12810 end if;
12811 end Is_Expression_Function_Or_Completion;
12812
12813 -----------------------
12814 -- Is_EVF_Expression --
12815 -----------------------
12816
12817 function Is_EVF_Expression (N : Node_Id) return Boolean is
12818 Orig_N : constant Node_Id := Original_Node (N);
12819 Alt : Node_Id;
12820 Expr : Node_Id;
12821 Id : Entity_Id;
12822
12823 begin
12824 -- Detect a reference to a formal parameter of a specific tagged type
12825 -- whose related subprogram is subject to pragma Expresions_Visible with
12826 -- value "False".
12827
12828 if Is_Entity_Name (N) and then Present (Entity (N)) then
12829 Id := Entity (N);
12830
12831 return
12832 Is_Formal (Id)
12833 and then Is_Specific_Tagged_Type (Etype (Id))
12834 and then Extensions_Visible_Status (Id) =
12835 Extensions_Visible_False;
12836
12837 -- A case expression is an EVF expression when it contains at least one
12838 -- EVF dependent_expression. Note that a case expression may have been
12839 -- expanded, hence the use of Original_Node.
12840
12841 elsif Nkind (Orig_N) = N_Case_Expression then
12842 Alt := First (Alternatives (Orig_N));
12843 while Present (Alt) loop
12844 if Is_EVF_Expression (Expression (Alt)) then
12845 return True;
12846 end if;
12847
12848 Next (Alt);
12849 end loop;
12850
12851 -- An if expression is an EVF expression when it contains at least one
12852 -- EVF dependent_expression. Note that an if expression may have been
12853 -- expanded, hence the use of Original_Node.
12854
12855 elsif Nkind (Orig_N) = N_If_Expression then
12856 Expr := Next (First (Expressions (Orig_N)));
12857 while Present (Expr) loop
12858 if Is_EVF_Expression (Expr) then
12859 return True;
12860 end if;
12861
12862 Next (Expr);
12863 end loop;
12864
12865 -- A qualified expression or a type conversion is an EVF expression when
12866 -- its operand is an EVF expression.
12867
12868 elsif Nkind_In (N, N_Qualified_Expression,
12869 N_Unchecked_Type_Conversion,
12870 N_Type_Conversion)
12871 then
12872 return Is_EVF_Expression (Expression (N));
12873
12874 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
12875 -- their prefix denotes an EVF expression.
12876
12877 elsif Nkind (N) = N_Attribute_Reference
12878 and then Nam_In (Attribute_Name (N), Name_Loop_Entry,
12879 Name_Old,
12880 Name_Update)
12881 then
12882 return Is_EVF_Expression (Prefix (N));
12883 end if;
12884
12885 return False;
12886 end Is_EVF_Expression;
12887
12888 --------------
12889 -- Is_False --
12890 --------------
12891
12892 function Is_False (U : Uint) return Boolean is
12893 begin
12894 return (U = 0);
12895 end Is_False;
12896
12897 ---------------------------
12898 -- Is_Fixed_Model_Number --
12899 ---------------------------
12900
12901 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
12902 S : constant Ureal := Small_Value (T);
12903 M : Urealp.Save_Mark;
12904 R : Boolean;
12905 begin
12906 M := Urealp.Mark;
12907 R := (U = UR_Trunc (U / S) * S);
12908 Urealp.Release (M);
12909 return R;
12910 end Is_Fixed_Model_Number;
12911
12912 -------------------------------
12913 -- Is_Fully_Initialized_Type --
12914 -------------------------------
12915
12916 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
12917 begin
12918 -- Scalar types
12919
12920 if Is_Scalar_Type (Typ) then
12921
12922 -- A scalar type with an aspect Default_Value is fully initialized
12923
12924 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
12925 -- of a scalar type, but we don't take that into account here, since
12926 -- we don't want these to affect warnings.
12927
12928 return Has_Default_Aspect (Typ);
12929
12930 elsif Is_Access_Type (Typ) then
12931 return True;
12932
12933 elsif Is_Array_Type (Typ) then
12934 if Is_Fully_Initialized_Type (Component_Type (Typ))
12935 or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
12936 then
12937 return True;
12938 end if;
12939
12940 -- An interesting case, if we have a constrained type one of whose
12941 -- bounds is known to be null, then there are no elements to be
12942 -- initialized, so all the elements are initialized.
12943
12944 if Is_Constrained (Typ) then
12945 declare
12946 Indx : Node_Id;
12947 Indx_Typ : Entity_Id;
12948 Lbd, Hbd : Node_Id;
12949
12950 begin
12951 Indx := First_Index (Typ);
12952 while Present (Indx) loop
12953 if Etype (Indx) = Any_Type then
12954 return False;
12955
12956 -- If index is a range, use directly
12957
12958 elsif Nkind (Indx) = N_Range then
12959 Lbd := Low_Bound (Indx);
12960 Hbd := High_Bound (Indx);
12961
12962 else
12963 Indx_Typ := Etype (Indx);
12964
12965 if Is_Private_Type (Indx_Typ) then
12966 Indx_Typ := Full_View (Indx_Typ);
12967 end if;
12968
12969 if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
12970 return False;
12971 else
12972 Lbd := Type_Low_Bound (Indx_Typ);
12973 Hbd := Type_High_Bound (Indx_Typ);
12974 end if;
12975 end if;
12976
12977 if Compile_Time_Known_Value (Lbd)
12978 and then
12979 Compile_Time_Known_Value (Hbd)
12980 then
12981 if Expr_Value (Hbd) < Expr_Value (Lbd) then
12982 return True;
12983 end if;
12984 end if;
12985
12986 Next_Index (Indx);
12987 end loop;
12988 end;
12989 end if;
12990
12991 -- If no null indexes, then type is not fully initialized
12992
12993 return False;
12994
12995 -- Record types
12996
12997 elsif Is_Record_Type (Typ) then
12998 if Has_Discriminants (Typ)
12999 and then
13000 Present (Discriminant_Default_Value (First_Discriminant (Typ)))
13001 and then Is_Fully_Initialized_Variant (Typ)
13002 then
13003 return True;
13004 end if;
13005
13006 -- We consider bounded string types to be fully initialized, because
13007 -- otherwise we get false alarms when the Data component is not
13008 -- default-initialized.
13009
13010 if Is_Bounded_String (Typ) then
13011 return True;
13012 end if;
13013
13014 -- Controlled records are considered to be fully initialized if
13015 -- there is a user defined Initialize routine. This may not be
13016 -- entirely correct, but as the spec notes, we are guessing here
13017 -- what is best from the point of view of issuing warnings.
13018
13019 if Is_Controlled (Typ) then
13020 declare
13021 Utyp : constant Entity_Id := Underlying_Type (Typ);
13022
13023 begin
13024 if Present (Utyp) then
13025 declare
13026 Init : constant Entity_Id :=
13027 (Find_Optional_Prim_Op
13028 (Underlying_Type (Typ), Name_Initialize));
13029
13030 begin
13031 if Present (Init)
13032 and then Comes_From_Source (Init)
13033 and then not
13034 Is_Predefined_File_Name
13035 (File_Name (Get_Source_File_Index (Sloc (Init))))
13036 then
13037 return True;
13038
13039 elsif Has_Null_Extension (Typ)
13040 and then
13041 Is_Fully_Initialized_Type
13042 (Etype (Base_Type (Typ)))
13043 then
13044 return True;
13045 end if;
13046 end;
13047 end if;
13048 end;
13049 end if;
13050
13051 -- Otherwise see if all record components are initialized
13052
13053 declare
13054 Ent : Entity_Id;
13055
13056 begin
13057 Ent := First_Entity (Typ);
13058 while Present (Ent) loop
13059 if Ekind (Ent) = E_Component
13060 and then (No (Parent (Ent))
13061 or else No (Expression (Parent (Ent))))
13062 and then not Is_Fully_Initialized_Type (Etype (Ent))
13063
13064 -- Special VM case for tag components, which need to be
13065 -- defined in this case, but are never initialized as VMs
13066 -- are using other dispatching mechanisms. Ignore this
13067 -- uninitialized case. Note that this applies both to the
13068 -- uTag entry and the main vtable pointer (CPP_Class case).
13069
13070 and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
13071 then
13072 return False;
13073 end if;
13074
13075 Next_Entity (Ent);
13076 end loop;
13077 end;
13078
13079 -- No uninitialized components, so type is fully initialized.
13080 -- Note that this catches the case of no components as well.
13081
13082 return True;
13083
13084 elsif Is_Concurrent_Type (Typ) then
13085 return True;
13086
13087 elsif Is_Private_Type (Typ) then
13088 declare
13089 U : constant Entity_Id := Underlying_Type (Typ);
13090
13091 begin
13092 if No (U) then
13093 return False;
13094 else
13095 return Is_Fully_Initialized_Type (U);
13096 end if;
13097 end;
13098
13099 else
13100 return False;
13101 end if;
13102 end Is_Fully_Initialized_Type;
13103
13104 ----------------------------------
13105 -- Is_Fully_Initialized_Variant --
13106 ----------------------------------
13107
13108 function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
13109 Loc : constant Source_Ptr := Sloc (Typ);
13110 Constraints : constant List_Id := New_List;
13111 Components : constant Elist_Id := New_Elmt_List;
13112 Comp_Elmt : Elmt_Id;
13113 Comp_Id : Node_Id;
13114 Comp_List : Node_Id;
13115 Discr : Entity_Id;
13116 Discr_Val : Node_Id;
13117
13118 Report_Errors : Boolean;
13119 pragma Warnings (Off, Report_Errors);
13120
13121 begin
13122 if Serious_Errors_Detected > 0 then
13123 return False;
13124 end if;
13125
13126 if Is_Record_Type (Typ)
13127 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
13128 and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
13129 then
13130 Comp_List := Component_List (Type_Definition (Parent (Typ)));
13131
13132 Discr := First_Discriminant (Typ);
13133 while Present (Discr) loop
13134 if Nkind (Parent (Discr)) = N_Discriminant_Specification then
13135 Discr_Val := Expression (Parent (Discr));
13136
13137 if Present (Discr_Val)
13138 and then Is_OK_Static_Expression (Discr_Val)
13139 then
13140 Append_To (Constraints,
13141 Make_Component_Association (Loc,
13142 Choices => New_List (New_Occurrence_Of (Discr, Loc)),
13143 Expression => New_Copy (Discr_Val)));
13144 else
13145 return False;
13146 end if;
13147 else
13148 return False;
13149 end if;
13150
13151 Next_Discriminant (Discr);
13152 end loop;
13153
13154 Gather_Components
13155 (Typ => Typ,
13156 Comp_List => Comp_List,
13157 Governed_By => Constraints,
13158 Into => Components,
13159 Report_Errors => Report_Errors);
13160
13161 -- Check that each component present is fully initialized
13162
13163 Comp_Elmt := First_Elmt (Components);
13164 while Present (Comp_Elmt) loop
13165 Comp_Id := Node (Comp_Elmt);
13166
13167 if Ekind (Comp_Id) = E_Component
13168 and then (No (Parent (Comp_Id))
13169 or else No (Expression (Parent (Comp_Id))))
13170 and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
13171 then
13172 return False;
13173 end if;
13174
13175 Next_Elmt (Comp_Elmt);
13176 end loop;
13177
13178 return True;
13179
13180 elsif Is_Private_Type (Typ) then
13181 declare
13182 U : constant Entity_Id := Underlying_Type (Typ);
13183
13184 begin
13185 if No (U) then
13186 return False;
13187 else
13188 return Is_Fully_Initialized_Variant (U);
13189 end if;
13190 end;
13191
13192 else
13193 return False;
13194 end if;
13195 end Is_Fully_Initialized_Variant;
13196
13197 ------------------------------------
13198 -- Is_Generic_Declaration_Or_Body --
13199 ------------------------------------
13200
13201 function Is_Generic_Declaration_Or_Body (Decl : Node_Id) return Boolean is
13202 Spec_Decl : Node_Id;
13203
13204 begin
13205 -- Package/subprogram body
13206
13207 if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body)
13208 and then Present (Corresponding_Spec (Decl))
13209 then
13210 Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl));
13211
13212 -- Package/subprogram body stub
13213
13214 elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub)
13215 and then Present (Corresponding_Spec_Of_Stub (Decl))
13216 then
13217 Spec_Decl :=
13218 Unit_Declaration_Node (Corresponding_Spec_Of_Stub (Decl));
13219
13220 -- All other cases
13221
13222 else
13223 Spec_Decl := Decl;
13224 end if;
13225
13226 -- Rather than inspecting the defining entity of the spec declaration,
13227 -- look at its Nkind. This takes care of the case where the analysis of
13228 -- a generic body modifies the Ekind of its spec to allow for recursive
13229 -- calls.
13230
13231 return
13232 Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
13233 N_Generic_Subprogram_Declaration);
13234 end Is_Generic_Declaration_Or_Body;
13235
13236 ----------------------------
13237 -- Is_Inherited_Operation --
13238 ----------------------------
13239
13240 function Is_Inherited_Operation (E : Entity_Id) return Boolean is
13241 pragma Assert (Is_Overloadable (E));
13242 Kind : constant Node_Kind := Nkind (Parent (E));
13243 begin
13244 return Kind = N_Full_Type_Declaration
13245 or else Kind = N_Private_Extension_Declaration
13246 or else Kind = N_Subtype_Declaration
13247 or else (Ekind (E) = E_Enumeration_Literal
13248 and then Is_Derived_Type (Etype (E)));
13249 end Is_Inherited_Operation;
13250
13251 -------------------------------------
13252 -- Is_Inherited_Operation_For_Type --
13253 -------------------------------------
13254
13255 function Is_Inherited_Operation_For_Type
13256 (E : Entity_Id;
13257 Typ : Entity_Id) return Boolean
13258 is
13259 begin
13260 -- Check that the operation has been created by the type declaration
13261
13262 return Is_Inherited_Operation (E)
13263 and then Defining_Identifier (Parent (E)) = Typ;
13264 end Is_Inherited_Operation_For_Type;
13265
13266 -----------------
13267 -- Is_Iterator --
13268 -----------------
13269
13270 function Is_Iterator (Typ : Entity_Id) return Boolean is
13271 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean;
13272 -- Determine whether type Iter_Typ is a predefined forward or reversible
13273 -- iterator.
13274
13275 ----------------------
13276 -- Denotes_Iterator --
13277 ----------------------
13278
13279 function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is
13280 begin
13281 -- Check that the name matches, and that the ultimate ancestor is in
13282 -- a predefined unit, i.e the one that declares iterator interfaces.
13283
13284 return
13285 Nam_In (Chars (Iter_Typ), Name_Forward_Iterator,
13286 Name_Reversible_Iterator)
13287 and then Is_Predefined_File_Name
13288 (Unit_File_Name (Get_Source_Unit (Root_Type (Iter_Typ))));
13289 end Denotes_Iterator;
13290
13291 -- Local variables
13292
13293 Iface_Elmt : Elmt_Id;
13294 Ifaces : Elist_Id;
13295
13296 -- Start of processing for Is_Iterator
13297
13298 begin
13299 -- The type may be a subtype of a descendant of the proper instance of
13300 -- the predefined interface type, so we must use the root type of the
13301 -- given type. The same is done for Is_Reversible_Iterator.
13302
13303 if Is_Class_Wide_Type (Typ)
13304 and then Denotes_Iterator (Root_Type (Typ))
13305 then
13306 return True;
13307
13308 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
13309 return False;
13310
13311 elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then
13312 return True;
13313
13314 else
13315 Collect_Interfaces (Typ, Ifaces);
13316
13317 Iface_Elmt := First_Elmt (Ifaces);
13318 while Present (Iface_Elmt) loop
13319 if Denotes_Iterator (Node (Iface_Elmt)) then
13320 return True;
13321 end if;
13322
13323 Next_Elmt (Iface_Elmt);
13324 end loop;
13325
13326 return False;
13327 end if;
13328 end Is_Iterator;
13329
13330 ----------------------------
13331 -- Is_Iterator_Over_Array --
13332 ----------------------------
13333
13334 function Is_Iterator_Over_Array (N : Node_Id) return Boolean is
13335 Container : constant Node_Id := Name (N);
13336 Container_Typ : constant Entity_Id := Base_Type (Etype (Container));
13337 begin
13338 return Is_Array_Type (Container_Typ);
13339 end Is_Iterator_Over_Array;
13340
13341 ------------
13342 -- Is_LHS --
13343 ------------
13344
13345 -- We seem to have a lot of overlapping functions that do similar things
13346 -- (testing for left hand sides or lvalues???).
13347
13348 function Is_LHS (N : Node_Id) return Is_LHS_Result is
13349 P : constant Node_Id := Parent (N);
13350
13351 begin
13352 -- Return True if we are the left hand side of an assignment statement
13353
13354 if Nkind (P) = N_Assignment_Statement then
13355 if Name (P) = N then
13356 return Yes;
13357 else
13358 return No;
13359 end if;
13360
13361 -- Case of prefix of indexed or selected component or slice
13362
13363 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
13364 and then N = Prefix (P)
13365 then
13366 -- Here we have the case where the parent P is N.Q or N(Q .. R).
13367 -- If P is an LHS, then N is also effectively an LHS, but there
13368 -- is an important exception. If N is of an access type, then
13369 -- what we really have is N.all.Q (or N.all(Q .. R)). In either
13370 -- case this makes N.all a left hand side but not N itself.
13371
13372 -- If we don't know the type yet, this is the case where we return
13373 -- Unknown, since the answer depends on the type which is unknown.
13374
13375 if No (Etype (N)) then
13376 return Unknown;
13377
13378 -- We have an Etype set, so we can check it
13379
13380 elsif Is_Access_Type (Etype (N)) then
13381 return No;
13382
13383 -- OK, not access type case, so just test whole expression
13384
13385 else
13386 return Is_LHS (P);
13387 end if;
13388
13389 -- All other cases are not left hand sides
13390
13391 else
13392 return No;
13393 end if;
13394 end Is_LHS;
13395
13396 -----------------------------
13397 -- Is_Library_Level_Entity --
13398 -----------------------------
13399
13400 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
13401 begin
13402 -- The following is a small optimization, and it also properly handles
13403 -- discriminals, which in task bodies might appear in expressions before
13404 -- the corresponding procedure has been created, and which therefore do
13405 -- not have an assigned scope.
13406
13407 if Is_Formal (E) then
13408 return False;
13409 end if;
13410
13411 -- Normal test is simply that the enclosing dynamic scope is Standard
13412
13413 return Enclosing_Dynamic_Scope (E) = Standard_Standard;
13414 end Is_Library_Level_Entity;
13415
13416 --------------------------------
13417 -- Is_Limited_Class_Wide_Type --
13418 --------------------------------
13419
13420 function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
13421 begin
13422 return
13423 Is_Class_Wide_Type (Typ)
13424 and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ));
13425 end Is_Limited_Class_Wide_Type;
13426
13427 ---------------------------------
13428 -- Is_Local_Variable_Reference --
13429 ---------------------------------
13430
13431 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
13432 begin
13433 if not Is_Entity_Name (Expr) then
13434 return False;
13435
13436 else
13437 declare
13438 Ent : constant Entity_Id := Entity (Expr);
13439 Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
13440 begin
13441 if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
13442 return False;
13443 else
13444 return Present (Sub) and then Sub = Current_Subprogram;
13445 end if;
13446 end;
13447 end if;
13448 end Is_Local_Variable_Reference;
13449
13450 -----------------------------------------------
13451 -- Is_Nontrivial_Default_Init_Cond_Procedure --
13452 -----------------------------------------------
13453
13454 function Is_Nontrivial_Default_Init_Cond_Procedure
13455 (Id : Entity_Id) return Boolean
13456 is
13457 Body_Decl : Node_Id;
13458 Stmt : Node_Id;
13459
13460 begin
13461 if Ekind (Id) = E_Procedure
13462 and then Is_Default_Init_Cond_Procedure (Id)
13463 then
13464 Body_Decl :=
13465 Unit_Declaration_Node
13466 (Corresponding_Body (Unit_Declaration_Node (Id)));
13467
13468 -- The body of the Default_Initial_Condition procedure must contain
13469 -- at least one statement, otherwise the generation of the subprogram
13470 -- body failed.
13471
13472 pragma Assert (Present (Handled_Statement_Sequence (Body_Decl)));
13473
13474 -- To qualify as nontrivial, the first statement of the procedure
13475 -- must be a check in the form of an if statement. If the original
13476 -- Default_Initial_Condition expression was folded, then the first
13477 -- statement is not a check.
13478
13479 Stmt := First (Statements (Handled_Statement_Sequence (Body_Decl)));
13480
13481 return
13482 Nkind (Stmt) = N_If_Statement
13483 and then Nkind (Original_Node (Stmt)) = N_Pragma;
13484 end if;
13485
13486 return False;
13487 end Is_Nontrivial_Default_Init_Cond_Procedure;
13488
13489 -------------------------
13490 -- Is_Null_Record_Type --
13491 -------------------------
13492
13493 function Is_Null_Record_Type (T : Entity_Id) return Boolean is
13494 Decl : constant Node_Id := Parent (T);
13495 begin
13496 return Nkind (Decl) = N_Full_Type_Declaration
13497 and then Nkind (Type_Definition (Decl)) = N_Record_Definition
13498 and then
13499 (No (Component_List (Type_Definition (Decl)))
13500 or else Null_Present (Component_List (Type_Definition (Decl))));
13501 end Is_Null_Record_Type;
13502
13503 -------------------------
13504 -- Is_Object_Reference --
13505 -------------------------
13506
13507 function Is_Object_Reference (N : Node_Id) return Boolean is
13508 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
13509 -- Determine whether N is the name of an internally-generated renaming
13510
13511 --------------------------------------
13512 -- Is_Internally_Generated_Renaming --
13513 --------------------------------------
13514
13515 function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
13516 P : Node_Id;
13517
13518 begin
13519 P := N;
13520 while Present (P) loop
13521 if Nkind (P) = N_Object_Renaming_Declaration then
13522 return not Comes_From_Source (P);
13523 elsif Is_List_Member (P) then
13524 return False;
13525 end if;
13526
13527 P := Parent (P);
13528 end loop;
13529
13530 return False;
13531 end Is_Internally_Generated_Renaming;
13532
13533 -- Start of processing for Is_Object_Reference
13534
13535 begin
13536 if Is_Entity_Name (N) then
13537 return Present (Entity (N)) and then Is_Object (Entity (N));
13538
13539 else
13540 case Nkind (N) is
13541 when N_Indexed_Component | N_Slice =>
13542 return
13543 Is_Object_Reference (Prefix (N))
13544 or else Is_Access_Type (Etype (Prefix (N)));
13545
13546 -- In Ada 95, a function call is a constant object; a procedure
13547 -- call is not.
13548
13549 when N_Function_Call =>
13550 return Etype (N) /= Standard_Void_Type;
13551
13552 -- Attributes 'Input, 'Loop_Entry, 'Old, and 'Result produce
13553 -- objects.
13554
13555 when N_Attribute_Reference =>
13556 return
13557 Nam_In (Attribute_Name (N), Name_Input,
13558 Name_Loop_Entry,
13559 Name_Old,
13560 Name_Result);
13561
13562 when N_Selected_Component =>
13563 return
13564 Is_Object_Reference (Selector_Name (N))
13565 and then
13566 (Is_Object_Reference (Prefix (N))
13567 or else Is_Access_Type (Etype (Prefix (N))));
13568
13569 when N_Explicit_Dereference =>
13570 return True;
13571
13572 -- A view conversion of a tagged object is an object reference
13573
13574 when N_Type_Conversion =>
13575 return Is_Tagged_Type (Etype (Subtype_Mark (N)))
13576 and then Is_Tagged_Type (Etype (Expression (N)))
13577 and then Is_Object_Reference (Expression (N));
13578
13579 -- An unchecked type conversion is considered to be an object if
13580 -- the operand is an object (this construction arises only as a
13581 -- result of expansion activities).
13582
13583 when N_Unchecked_Type_Conversion =>
13584 return True;
13585
13586 -- Allow string literals to act as objects as long as they appear
13587 -- in internally-generated renamings. The expansion of iterators
13588 -- may generate such renamings when the range involves a string
13589 -- literal.
13590
13591 when N_String_Literal =>
13592 return Is_Internally_Generated_Renaming (Parent (N));
13593
13594 -- AI05-0003: In Ada 2012 a qualified expression is a name.
13595 -- This allows disambiguation of function calls and the use
13596 -- of aggregates in more contexts.
13597
13598 when N_Qualified_Expression =>
13599 if Ada_Version < Ada_2012 then
13600 return False;
13601 else
13602 return Is_Object_Reference (Expression (N))
13603 or else Nkind (Expression (N)) = N_Aggregate;
13604 end if;
13605
13606 when others =>
13607 return False;
13608 end case;
13609 end if;
13610 end Is_Object_Reference;
13611
13612 -----------------------------------
13613 -- Is_OK_Variable_For_Out_Formal --
13614 -----------------------------------
13615
13616 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
13617 begin
13618 Note_Possible_Modification (AV, Sure => True);
13619
13620 -- We must reject parenthesized variable names. Comes_From_Source is
13621 -- checked because there are currently cases where the compiler violates
13622 -- this rule (e.g. passing a task object to its controlled Initialize
13623 -- routine). This should be properly documented in sinfo???
13624
13625 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
13626 return False;
13627
13628 -- A variable is always allowed
13629
13630 elsif Is_Variable (AV) then
13631 return True;
13632
13633 -- Generalized indexing operations are rewritten as explicit
13634 -- dereferences, and it is only during resolution that we can
13635 -- check whether the context requires an access_to_variable type.
13636
13637 elsif Nkind (AV) = N_Explicit_Dereference
13638 and then Ada_Version >= Ada_2012
13639 and then Nkind (Original_Node (AV)) = N_Indexed_Component
13640 and then Present (Etype (Original_Node (AV)))
13641 and then Has_Implicit_Dereference (Etype (Original_Node (AV)))
13642 then
13643 return not Is_Access_Constant (Etype (Prefix (AV)));
13644
13645 -- Unchecked conversions are allowed only if they come from the
13646 -- generated code, which sometimes uses unchecked conversions for out
13647 -- parameters in cases where code generation is unaffected. We tell
13648 -- source unchecked conversions by seeing if they are rewrites of
13649 -- an original Unchecked_Conversion function call, or of an explicit
13650 -- conversion of a function call or an aggregate (as may happen in the
13651 -- expansion of a packed array aggregate).
13652
13653 elsif Nkind (AV) = N_Unchecked_Type_Conversion then
13654 if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then
13655 return False;
13656
13657 elsif Comes_From_Source (AV)
13658 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
13659 then
13660 return False;
13661
13662 elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
13663 return Is_OK_Variable_For_Out_Formal (Expression (AV));
13664
13665 else
13666 return True;
13667 end if;
13668
13669 -- Normal type conversions are allowed if argument is a variable
13670
13671 elsif Nkind (AV) = N_Type_Conversion then
13672 if Is_Variable (Expression (AV))
13673 and then Paren_Count (Expression (AV)) = 0
13674 then
13675 Note_Possible_Modification (Expression (AV), Sure => True);
13676 return True;
13677
13678 -- We also allow a non-parenthesized expression that raises
13679 -- constraint error if it rewrites what used to be a variable
13680
13681 elsif Raises_Constraint_Error (Expression (AV))
13682 and then Paren_Count (Expression (AV)) = 0
13683 and then Is_Variable (Original_Node (Expression (AV)))
13684 then
13685 return True;
13686
13687 -- Type conversion of something other than a variable
13688
13689 else
13690 return False;
13691 end if;
13692
13693 -- If this node is rewritten, then test the original form, if that is
13694 -- OK, then we consider the rewritten node OK (for example, if the
13695 -- original node is a conversion, then Is_Variable will not be true
13696 -- but we still want to allow the conversion if it converts a variable).
13697
13698 elsif Original_Node (AV) /= AV then
13699
13700 -- In Ada 2012, the explicit dereference may be a rewritten call to a
13701 -- Reference function.
13702
13703 if Ada_Version >= Ada_2012
13704 and then Nkind (Original_Node (AV)) = N_Function_Call
13705 and then
13706 Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
13707 then
13708
13709 -- Check that this is not a constant reference.
13710
13711 return not Is_Access_Constant (Etype (Prefix (AV)));
13712
13713 elsif Has_Implicit_Dereference (Etype (Original_Node (AV))) then
13714 return
13715 not Is_Access_Constant (Etype
13716 (Get_Reference_Discriminant (Etype (Original_Node (AV)))));
13717
13718 else
13719 return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
13720 end if;
13721
13722 -- All other non-variables are rejected
13723
13724 else
13725 return False;
13726 end if;
13727 end Is_OK_Variable_For_Out_Formal;
13728
13729 ----------------------------
13730 -- Is_OK_Volatile_Context --
13731 ----------------------------
13732
13733 function Is_OK_Volatile_Context
13734 (Context : Node_Id;
13735 Obj_Ref : Node_Id) return Boolean
13736 is
13737 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean;
13738 -- Determine whether an arbitrary node denotes a call to a protected
13739 -- entry, function, or procedure in prefixed form where the prefix is
13740 -- Obj_Ref.
13741
13742 function Within_Check (Nod : Node_Id) return Boolean;
13743 -- Determine whether an arbitrary node appears in a check node
13744
13745 function Within_Subprogram_Call (Nod : Node_Id) return Boolean;
13746 -- Determine whether an arbitrary node appears in an entry, function, or
13747 -- procedure call.
13748
13749 function Within_Volatile_Function (Id : Entity_Id) return Boolean;
13750 -- Determine whether an arbitrary entity appears in a volatile function
13751
13752 ---------------------------------
13753 -- Is_Protected_Operation_Call --
13754 ---------------------------------
13755
13756 function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is
13757 Pref : Node_Id;
13758 Subp : Node_Id;
13759
13760 begin
13761 -- A call to a protected operations retains its selected component
13762 -- form as opposed to other prefixed calls that are transformed in
13763 -- expanded names.
13764
13765 if Nkind (Nod) = N_Selected_Component then
13766 Pref := Prefix (Nod);
13767 Subp := Selector_Name (Nod);
13768
13769 return
13770 Pref = Obj_Ref
13771 and then Present (Etype (Pref))
13772 and then Is_Protected_Type (Etype (Pref))
13773 and then Is_Entity_Name (Subp)
13774 and then Present (Entity (Subp))
13775 and then Ekind_In (Entity (Subp), E_Entry,
13776 E_Entry_Family,
13777 E_Function,
13778 E_Procedure);
13779 else
13780 return False;
13781 end if;
13782 end Is_Protected_Operation_Call;
13783
13784 ------------------
13785 -- Within_Check --
13786 ------------------
13787
13788 function Within_Check (Nod : Node_Id) return Boolean is
13789 Par : Node_Id;
13790
13791 begin
13792 -- Climb the parent chain looking for a check node
13793
13794 Par := Nod;
13795 while Present (Par) loop
13796 if Nkind (Par) in N_Raise_xxx_Error then
13797 return True;
13798
13799 -- Prevent the search from going too far
13800
13801 elsif Is_Body_Or_Package_Declaration (Par) then
13802 exit;
13803 end if;
13804
13805 Par := Parent (Par);
13806 end loop;
13807
13808 return False;
13809 end Within_Check;
13810
13811 ----------------------------
13812 -- Within_Subprogram_Call --
13813 ----------------------------
13814
13815 function Within_Subprogram_Call (Nod : Node_Id) return Boolean is
13816 Par : Node_Id;
13817
13818 begin
13819 -- Climb the parent chain looking for a function or procedure call
13820
13821 Par := Nod;
13822 while Present (Par) loop
13823 if Nkind_In (Par, N_Entry_Call_Statement,
13824 N_Function_Call,
13825 N_Procedure_Call_Statement)
13826 then
13827 return True;
13828
13829 -- Prevent the search from going too far
13830
13831 elsif Is_Body_Or_Package_Declaration (Par) then
13832 exit;
13833 end if;
13834
13835 Par := Parent (Par);
13836 end loop;
13837
13838 return False;
13839 end Within_Subprogram_Call;
13840
13841 ------------------------------
13842 -- Within_Volatile_Function --
13843 ------------------------------
13844
13845 function Within_Volatile_Function (Id : Entity_Id) return Boolean is
13846 Func_Id : Entity_Id;
13847
13848 begin
13849 -- Traverse the scope stack looking for a [generic] function
13850
13851 Func_Id := Id;
13852 while Present (Func_Id) and then Func_Id /= Standard_Standard loop
13853 if Ekind_In (Func_Id, E_Function, E_Generic_Function) then
13854 return Is_Volatile_Function (Func_Id);
13855 end if;
13856
13857 Func_Id := Scope (Func_Id);
13858 end loop;
13859
13860 return False;
13861 end Within_Volatile_Function;
13862
13863 -- Local variables
13864
13865 Obj_Id : Entity_Id;
13866
13867 -- Start of processing for Is_OK_Volatile_Context
13868
13869 begin
13870 -- The volatile object appears on either side of an assignment
13871
13872 if Nkind (Context) = N_Assignment_Statement then
13873 return True;
13874
13875 -- The volatile object is part of the initialization expression of
13876 -- another object.
13877
13878 elsif Nkind (Context) = N_Object_Declaration
13879 and then Present (Expression (Context))
13880 and then Expression (Context) = Obj_Ref
13881 then
13882 Obj_Id := Defining_Entity (Context);
13883
13884 -- The volatile object acts as the initialization expression of an
13885 -- extended return statement. This is valid context as long as the
13886 -- function is volatile.
13887
13888 if Is_Return_Object (Obj_Id) then
13889 return Within_Volatile_Function (Obj_Id);
13890
13891 -- Otherwise this is a normal object initialization
13892
13893 else
13894 return True;
13895 end if;
13896
13897 -- The volatile object acts as the name of a renaming declaration
13898
13899 elsif Nkind (Context) = N_Object_Renaming_Declaration
13900 and then Name (Context) = Obj_Ref
13901 then
13902 return True;
13903
13904 -- The volatile object appears as an actual parameter in a call to an
13905 -- instance of Unchecked_Conversion whose result is renamed.
13906
13907 elsif Nkind (Context) = N_Function_Call
13908 and then Is_Entity_Name (Name (Context))
13909 and then Is_Unchecked_Conversion_Instance (Entity (Name (Context)))
13910 and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration
13911 then
13912 return True;
13913
13914 -- The volatile object is actually the prefix in a protected entry,
13915 -- function, or procedure call.
13916
13917 elsif Is_Protected_Operation_Call (Context) then
13918 return True;
13919
13920 -- The volatile object appears as the expression of a simple return
13921 -- statement that applies to a volatile function.
13922
13923 elsif Nkind (Context) = N_Simple_Return_Statement
13924 and then Expression (Context) = Obj_Ref
13925 then
13926 return
13927 Within_Volatile_Function (Return_Statement_Entity (Context));
13928
13929 -- The volatile object appears as the prefix of a name occurring in a
13930 -- non-interfering context.
13931
13932 elsif Nkind_In (Context, N_Attribute_Reference,
13933 N_Explicit_Dereference,
13934 N_Indexed_Component,
13935 N_Selected_Component,
13936 N_Slice)
13937 and then Prefix (Context) = Obj_Ref
13938 and then Is_OK_Volatile_Context
13939 (Context => Parent (Context),
13940 Obj_Ref => Context)
13941 then
13942 return True;
13943
13944 -- The volatile object appears as the prefix of attributes Address,
13945 -- Alignment, Component_Size, First_Bit, Last_Bit, Position, Size,
13946 -- Storage_Size.
13947
13948 elsif Nkind (Context) = N_Attribute_Reference
13949 and then Prefix (Context) = Obj_Ref
13950 and then Nam_In (Attribute_Name (Context), Name_Address,
13951 Name_Alignment,
13952 Name_Component_Size,
13953 Name_First_Bit,
13954 Name_Last_Bit,
13955 Name_Position,
13956 Name_Size,
13957 Name_Storage_Size)
13958 then
13959 return True;
13960
13961 -- The volatile object appears as the expression of a type conversion
13962 -- occurring in a non-interfering context.
13963
13964 elsif Nkind_In (Context, N_Type_Conversion,
13965 N_Unchecked_Type_Conversion)
13966 and then Expression (Context) = Obj_Ref
13967 and then Is_OK_Volatile_Context
13968 (Context => Parent (Context),
13969 Obj_Ref => Context)
13970 then
13971 return True;
13972
13973 -- Allow references to volatile objects in various checks. This is not a
13974 -- direct SPARK 2014 requirement.
13975
13976 elsif Within_Check (Context) then
13977 return True;
13978
13979 -- Assume that references to effectively volatile objects that appear
13980 -- as actual parameters in a subprogram call are always legal. A full
13981 -- legality check is done when the actuals are resolved (see routine
13982 -- Resolve_Actuals).
13983
13984 elsif Within_Subprogram_Call (Context) then
13985 return True;
13986
13987 -- Otherwise the context is not suitable for an effectively volatile
13988 -- object.
13989
13990 else
13991 return False;
13992 end if;
13993 end Is_OK_Volatile_Context;
13994
13995 ------------------------------------
13996 -- Is_Package_Contract_Annotation --
13997 ------------------------------------
13998
13999 function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean is
14000 Nam : Name_Id;
14001
14002 begin
14003 if Nkind (Item) = N_Aspect_Specification then
14004 Nam := Chars (Identifier (Item));
14005
14006 else pragma Assert (Nkind (Item) = N_Pragma);
14007 Nam := Pragma_Name (Item);
14008 end if;
14009
14010 return Nam = Name_Abstract_State
14011 or else Nam = Name_Initial_Condition
14012 or else Nam = Name_Initializes
14013 or else Nam = Name_Refined_State;
14014 end Is_Package_Contract_Annotation;
14015
14016 -----------------------------------
14017 -- Is_Partially_Initialized_Type --
14018 -----------------------------------
14019
14020 function Is_Partially_Initialized_Type
14021 (Typ : Entity_Id;
14022 Include_Implicit : Boolean := True) return Boolean
14023 is
14024 begin
14025 if Is_Scalar_Type (Typ) then
14026 return False;
14027
14028 elsif Is_Access_Type (Typ) then
14029 return Include_Implicit;
14030
14031 elsif Is_Array_Type (Typ) then
14032
14033 -- If component type is partially initialized, so is array type
14034
14035 if Is_Partially_Initialized_Type
14036 (Component_Type (Typ), Include_Implicit)
14037 then
14038 return True;
14039
14040 -- Otherwise we are only partially initialized if we are fully
14041 -- initialized (this is the empty array case, no point in us
14042 -- duplicating that code here).
14043
14044 else
14045 return Is_Fully_Initialized_Type (Typ);
14046 end if;
14047
14048 elsif Is_Record_Type (Typ) then
14049
14050 -- A discriminated type is always partially initialized if in
14051 -- all mode
14052
14053 if Has_Discriminants (Typ) and then Include_Implicit then
14054 return True;
14055
14056 -- A tagged type is always partially initialized
14057
14058 elsif Is_Tagged_Type (Typ) then
14059 return True;
14060
14061 -- Case of non-discriminated record
14062
14063 else
14064 declare
14065 Ent : Entity_Id;
14066
14067 Component_Present : Boolean := False;
14068 -- Set True if at least one component is present. If no
14069 -- components are present, then record type is fully
14070 -- initialized (another odd case, like the null array).
14071
14072 begin
14073 -- Loop through components
14074
14075 Ent := First_Entity (Typ);
14076 while Present (Ent) loop
14077 if Ekind (Ent) = E_Component then
14078 Component_Present := True;
14079
14080 -- If a component has an initialization expression then
14081 -- the enclosing record type is partially initialized
14082
14083 if Present (Parent (Ent))
14084 and then Present (Expression (Parent (Ent)))
14085 then
14086 return True;
14087
14088 -- If a component is of a type which is itself partially
14089 -- initialized, then the enclosing record type is also.
14090
14091 elsif Is_Partially_Initialized_Type
14092 (Etype (Ent), Include_Implicit)
14093 then
14094 return True;
14095 end if;
14096 end if;
14097
14098 Next_Entity (Ent);
14099 end loop;
14100
14101 -- No initialized components found. If we found any components
14102 -- they were all uninitialized so the result is false.
14103
14104 if Component_Present then
14105 return False;
14106
14107 -- But if we found no components, then all the components are
14108 -- initialized so we consider the type to be initialized.
14109
14110 else
14111 return True;
14112 end if;
14113 end;
14114 end if;
14115
14116 -- Concurrent types are always fully initialized
14117
14118 elsif Is_Concurrent_Type (Typ) then
14119 return True;
14120
14121 -- For a private type, go to underlying type. If there is no underlying
14122 -- type then just assume this partially initialized. Not clear if this
14123 -- can happen in a non-error case, but no harm in testing for this.
14124
14125 elsif Is_Private_Type (Typ) then
14126 declare
14127 U : constant Entity_Id := Underlying_Type (Typ);
14128 begin
14129 if No (U) then
14130 return True;
14131 else
14132 return Is_Partially_Initialized_Type (U, Include_Implicit);
14133 end if;
14134 end;
14135
14136 -- For any other type (are there any?) assume partially initialized
14137
14138 else
14139 return True;
14140 end if;
14141 end Is_Partially_Initialized_Type;
14142
14143 ------------------------------------
14144 -- Is_Potentially_Persistent_Type --
14145 ------------------------------------
14146
14147 function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
14148 Comp : Entity_Id;
14149 Indx : Node_Id;
14150
14151 begin
14152 -- For private type, test corresponding full type
14153
14154 if Is_Private_Type (T) then
14155 return Is_Potentially_Persistent_Type (Full_View (T));
14156
14157 -- Scalar types are potentially persistent
14158
14159 elsif Is_Scalar_Type (T) then
14160 return True;
14161
14162 -- Record type is potentially persistent if not tagged and the types of
14163 -- all it components are potentially persistent, and no component has
14164 -- an initialization expression.
14165
14166 elsif Is_Record_Type (T)
14167 and then not Is_Tagged_Type (T)
14168 and then not Is_Partially_Initialized_Type (T)
14169 then
14170 Comp := First_Component (T);
14171 while Present (Comp) loop
14172 if not Is_Potentially_Persistent_Type (Etype (Comp)) then
14173 return False;
14174 else
14175 Next_Entity (Comp);
14176 end if;
14177 end loop;
14178
14179 return True;
14180
14181 -- Array type is potentially persistent if its component type is
14182 -- potentially persistent and if all its constraints are static.
14183
14184 elsif Is_Array_Type (T) then
14185 if not Is_Potentially_Persistent_Type (Component_Type (T)) then
14186 return False;
14187 end if;
14188
14189 Indx := First_Index (T);
14190 while Present (Indx) loop
14191 if not Is_OK_Static_Subtype (Etype (Indx)) then
14192 return False;
14193 else
14194 Next_Index (Indx);
14195 end if;
14196 end loop;
14197
14198 return True;
14199
14200 -- All other types are not potentially persistent
14201
14202 else
14203 return False;
14204 end if;
14205 end Is_Potentially_Persistent_Type;
14206
14207 --------------------------------
14208 -- Is_Potentially_Unevaluated --
14209 --------------------------------
14210
14211 function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is
14212 Par : Node_Id;
14213 Expr : Node_Id;
14214
14215 begin
14216 Expr := N;
14217 Par := Parent (N);
14218
14219 -- A postcondition whose expression is a short-circuit is broken down
14220 -- into individual aspects for better exception reporting. The original
14221 -- short-circuit expression is rewritten as the second operand, and an
14222 -- occurrence of 'Old in that operand is potentially unevaluated.
14223 -- See Sem_ch13.adb for details of this transformation.
14224
14225 if Nkind (Original_Node (Par)) = N_And_Then then
14226 return True;
14227 end if;
14228
14229 while not Nkind_In (Par, N_If_Expression,
14230 N_Case_Expression,
14231 N_And_Then,
14232 N_Or_Else,
14233 N_In,
14234 N_Not_In)
14235 loop
14236 Expr := Par;
14237 Par := Parent (Par);
14238
14239 -- If the context is not an expression, or if is the result of
14240 -- expansion of an enclosing construct (such as another attribute)
14241 -- the predicate does not apply.
14242
14243 if Nkind (Par) not in N_Subexpr
14244 or else not Comes_From_Source (Par)
14245 then
14246 return False;
14247 end if;
14248 end loop;
14249
14250 if Nkind (Par) = N_If_Expression then
14251 return Is_Elsif (Par) or else Expr /= First (Expressions (Par));
14252
14253 elsif Nkind (Par) = N_Case_Expression then
14254 return Expr /= Expression (Par);
14255
14256 elsif Nkind_In (Par, N_And_Then, N_Or_Else) then
14257 return Expr = Right_Opnd (Par);
14258
14259 elsif Nkind_In (Par, N_In, N_Not_In) then
14260 return Expr /= Left_Opnd (Par);
14261
14262 else
14263 return False;
14264 end if;
14265 end Is_Potentially_Unevaluated;
14266
14267 ---------------------------------
14268 -- Is_Protected_Self_Reference --
14269 ---------------------------------
14270
14271 function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
14272
14273 function In_Access_Definition (N : Node_Id) return Boolean;
14274 -- Returns true if N belongs to an access definition
14275
14276 --------------------------
14277 -- In_Access_Definition --
14278 --------------------------
14279
14280 function In_Access_Definition (N : Node_Id) return Boolean is
14281 P : Node_Id;
14282
14283 begin
14284 P := Parent (N);
14285 while Present (P) loop
14286 if Nkind (P) = N_Access_Definition then
14287 return True;
14288 end if;
14289
14290 P := Parent (P);
14291 end loop;
14292
14293 return False;
14294 end In_Access_Definition;
14295
14296 -- Start of processing for Is_Protected_Self_Reference
14297
14298 begin
14299 -- Verify that prefix is analyzed and has the proper form. Note that
14300 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
14301 -- produce the address of an entity, do not analyze their prefix
14302 -- because they denote entities that are not necessarily visible.
14303 -- Neither of them can apply to a protected type.
14304
14305 return Ada_Version >= Ada_2005
14306 and then Is_Entity_Name (N)
14307 and then Present (Entity (N))
14308 and then Is_Protected_Type (Entity (N))
14309 and then In_Open_Scopes (Entity (N))
14310 and then not In_Access_Definition (N);
14311 end Is_Protected_Self_Reference;
14312
14313 -----------------------------
14314 -- Is_RCI_Pkg_Spec_Or_Body --
14315 -----------------------------
14316
14317 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
14318
14319 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
14320 -- Return True if the unit of Cunit is an RCI package declaration
14321
14322 ---------------------------
14323 -- Is_RCI_Pkg_Decl_Cunit --
14324 ---------------------------
14325
14326 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
14327 The_Unit : constant Node_Id := Unit (Cunit);
14328
14329 begin
14330 if Nkind (The_Unit) /= N_Package_Declaration then
14331 return False;
14332 end if;
14333
14334 return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
14335 end Is_RCI_Pkg_Decl_Cunit;
14336
14337 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
14338
14339 begin
14340 return Is_RCI_Pkg_Decl_Cunit (Cunit)
14341 or else
14342 (Nkind (Unit (Cunit)) = N_Package_Body
14343 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
14344 end Is_RCI_Pkg_Spec_Or_Body;
14345
14346 -----------------------------------------
14347 -- Is_Remote_Access_To_Class_Wide_Type --
14348 -----------------------------------------
14349
14350 function Is_Remote_Access_To_Class_Wide_Type
14351 (E : Entity_Id) return Boolean
14352 is
14353 begin
14354 -- A remote access to class-wide type is a general access to object type
14355 -- declared in the visible part of a Remote_Types or Remote_Call_
14356 -- Interface unit.
14357
14358 return Ekind (E) = E_General_Access_Type
14359 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
14360 end Is_Remote_Access_To_Class_Wide_Type;
14361
14362 -----------------------------------------
14363 -- Is_Remote_Access_To_Subprogram_Type --
14364 -----------------------------------------
14365
14366 function Is_Remote_Access_To_Subprogram_Type
14367 (E : Entity_Id) return Boolean
14368 is
14369 begin
14370 return (Ekind (E) = E_Access_Subprogram_Type
14371 or else (Ekind (E) = E_Record_Type
14372 and then Present (Corresponding_Remote_Type (E))))
14373 and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
14374 end Is_Remote_Access_To_Subprogram_Type;
14375
14376 --------------------
14377 -- Is_Remote_Call --
14378 --------------------
14379
14380 function Is_Remote_Call (N : Node_Id) return Boolean is
14381 begin
14382 if Nkind (N) not in N_Subprogram_Call then
14383
14384 -- An entry call cannot be remote
14385
14386 return False;
14387
14388 elsif Nkind (Name (N)) in N_Has_Entity
14389 and then Is_Remote_Call_Interface (Entity (Name (N)))
14390 then
14391 -- A subprogram declared in the spec of a RCI package is remote
14392
14393 return True;
14394
14395 elsif Nkind (Name (N)) = N_Explicit_Dereference
14396 and then Is_Remote_Access_To_Subprogram_Type
14397 (Etype (Prefix (Name (N))))
14398 then
14399 -- The dereference of a RAS is a remote call
14400
14401 return True;
14402
14403 elsif Present (Controlling_Argument (N))
14404 and then Is_Remote_Access_To_Class_Wide_Type
14405 (Etype (Controlling_Argument (N)))
14406 then
14407 -- Any primitive operation call with a controlling argument of
14408 -- a RACW type is a remote call.
14409
14410 return True;
14411 end if;
14412
14413 -- All other calls are local calls
14414
14415 return False;
14416 end Is_Remote_Call;
14417
14418 ----------------------
14419 -- Is_Renamed_Entry --
14420 ----------------------
14421
14422 function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
14423 Orig_Node : Node_Id := Empty;
14424 Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
14425
14426 function Is_Entry (Nam : Node_Id) return Boolean;
14427 -- Determine whether Nam is an entry. Traverse selectors if there are
14428 -- nested selected components.
14429
14430 --------------
14431 -- Is_Entry --
14432 --------------
14433
14434 function Is_Entry (Nam : Node_Id) return Boolean is
14435 begin
14436 if Nkind (Nam) = N_Selected_Component then
14437 return Is_Entry (Selector_Name (Nam));
14438 end if;
14439
14440 return Ekind (Entity (Nam)) = E_Entry;
14441 end Is_Entry;
14442
14443 -- Start of processing for Is_Renamed_Entry
14444
14445 begin
14446 if Present (Alias (Proc_Nam)) then
14447 Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
14448 end if;
14449
14450 -- Look for a rewritten subprogram renaming declaration
14451
14452 if Nkind (Subp_Decl) = N_Subprogram_Declaration
14453 and then Present (Original_Node (Subp_Decl))
14454 then
14455 Orig_Node := Original_Node (Subp_Decl);
14456 end if;
14457
14458 -- The rewritten subprogram is actually an entry
14459
14460 if Present (Orig_Node)
14461 and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
14462 and then Is_Entry (Name (Orig_Node))
14463 then
14464 return True;
14465 end if;
14466
14467 return False;
14468 end Is_Renamed_Entry;
14469
14470 -----------------------------
14471 -- Is_Renaming_Declaration --
14472 -----------------------------
14473
14474 function Is_Renaming_Declaration (N : Node_Id) return Boolean is
14475 begin
14476 case Nkind (N) is
14477 when N_Exception_Renaming_Declaration |
14478 N_Generic_Function_Renaming_Declaration |
14479 N_Generic_Package_Renaming_Declaration |
14480 N_Generic_Procedure_Renaming_Declaration |
14481 N_Object_Renaming_Declaration |
14482 N_Package_Renaming_Declaration |
14483 N_Subprogram_Renaming_Declaration =>
14484 return True;
14485
14486 when others =>
14487 return False;
14488 end case;
14489 end Is_Renaming_Declaration;
14490
14491 ----------------------------
14492 -- Is_Reversible_Iterator --
14493 ----------------------------
14494
14495 function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
14496 Ifaces_List : Elist_Id;
14497 Iface_Elmt : Elmt_Id;
14498 Iface : Entity_Id;
14499
14500 begin
14501 if Is_Class_Wide_Type (Typ)
14502 and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator
14503 and then Is_Predefined_File_Name
14504 (Unit_File_Name (Get_Source_Unit (Root_Type (Typ))))
14505 then
14506 return True;
14507
14508 elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
14509 return False;
14510
14511 else
14512 Collect_Interfaces (Typ, Ifaces_List);
14513
14514 Iface_Elmt := First_Elmt (Ifaces_List);
14515 while Present (Iface_Elmt) loop
14516 Iface := Node (Iface_Elmt);
14517 if Chars (Iface) = Name_Reversible_Iterator
14518 and then
14519 Is_Predefined_File_Name
14520 (Unit_File_Name (Get_Source_Unit (Iface)))
14521 then
14522 return True;
14523 end if;
14524
14525 Next_Elmt (Iface_Elmt);
14526 end loop;
14527 end if;
14528
14529 return False;
14530 end Is_Reversible_Iterator;
14531
14532 ----------------------
14533 -- Is_Selector_Name --
14534 ----------------------
14535
14536 function Is_Selector_Name (N : Node_Id) return Boolean is
14537 begin
14538 if not Is_List_Member (N) then
14539 declare
14540 P : constant Node_Id := Parent (N);
14541 begin
14542 return Nkind_In (P, N_Expanded_Name,
14543 N_Generic_Association,
14544 N_Parameter_Association,
14545 N_Selected_Component)
14546 and then Selector_Name (P) = N;
14547 end;
14548
14549 else
14550 declare
14551 L : constant List_Id := List_Containing (N);
14552 P : constant Node_Id := Parent (L);
14553 begin
14554 return (Nkind (P) = N_Discriminant_Association
14555 and then Selector_Names (P) = L)
14556 or else
14557 (Nkind (P) = N_Component_Association
14558 and then Choices (P) = L);
14559 end;
14560 end if;
14561 end Is_Selector_Name;
14562
14563 ---------------------------------
14564 -- Is_Single_Concurrent_Object --
14565 ---------------------------------
14566
14567 function Is_Single_Concurrent_Object (Id : Entity_Id) return Boolean is
14568 begin
14569 return
14570 Is_Single_Protected_Object (Id) or else Is_Single_Task_Object (Id);
14571 end Is_Single_Concurrent_Object;
14572
14573 -------------------------------
14574 -- Is_Single_Concurrent_Type --
14575 -------------------------------
14576
14577 function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is
14578 begin
14579 return
14580 Ekind_In (Id, E_Protected_Type, E_Task_Type)
14581 and then Is_Single_Concurrent_Type_Declaration
14582 (Declaration_Node (Id));
14583 end Is_Single_Concurrent_Type;
14584
14585 -------------------------------------------
14586 -- Is_Single_Concurrent_Type_Declaration --
14587 -------------------------------------------
14588
14589 function Is_Single_Concurrent_Type_Declaration
14590 (N : Node_Id) return Boolean
14591 is
14592 begin
14593 return Nkind_In (Original_Node (N), N_Single_Protected_Declaration,
14594 N_Single_Task_Declaration);
14595 end Is_Single_Concurrent_Type_Declaration;
14596
14597 ---------------------------------------------
14598 -- Is_Single_Precision_Floating_Point_Type --
14599 ---------------------------------------------
14600
14601 function Is_Single_Precision_Floating_Point_Type
14602 (E : Entity_Id) return Boolean is
14603 begin
14604 return Is_Floating_Point_Type (E)
14605 and then Machine_Radix_Value (E) = Uint_2
14606 and then Machine_Mantissa_Value (E) = Uint_24
14607 and then Machine_Emax_Value (E) = Uint_2 ** Uint_7
14608 and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_7);
14609 end Is_Single_Precision_Floating_Point_Type;
14610
14611 --------------------------------
14612 -- Is_Single_Protected_Object --
14613 --------------------------------
14614
14615 function Is_Single_Protected_Object (Id : Entity_Id) return Boolean is
14616 begin
14617 return
14618 Ekind (Id) = E_Variable
14619 and then Ekind (Etype (Id)) = E_Protected_Type
14620 and then Is_Single_Concurrent_Type (Etype (Id));
14621 end Is_Single_Protected_Object;
14622
14623 ---------------------------
14624 -- Is_Single_Task_Object --
14625 ---------------------------
14626
14627 function Is_Single_Task_Object (Id : Entity_Id) return Boolean is
14628 begin
14629 return
14630 Ekind (Id) = E_Variable
14631 and then Ekind (Etype (Id)) = E_Task_Type
14632 and then Is_Single_Concurrent_Type (Etype (Id));
14633 end Is_Single_Task_Object;
14634
14635 -------------------------------------
14636 -- Is_SPARK_05_Initialization_Expr --
14637 -------------------------------------
14638
14639 function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is
14640 Is_Ok : Boolean;
14641 Expr : Node_Id;
14642 Comp_Assn : Node_Id;
14643 Orig_N : constant Node_Id := Original_Node (N);
14644
14645 begin
14646 Is_Ok := True;
14647
14648 if not Comes_From_Source (Orig_N) then
14649 goto Done;
14650 end if;
14651
14652 pragma Assert (Nkind (Orig_N) in N_Subexpr);
14653
14654 case Nkind (Orig_N) is
14655 when N_Character_Literal |
14656 N_Integer_Literal |
14657 N_Real_Literal |
14658 N_String_Literal =>
14659 null;
14660
14661 when N_Identifier |
14662 N_Expanded_Name =>
14663 if Is_Entity_Name (Orig_N)
14664 and then Present (Entity (Orig_N)) -- needed in some cases
14665 then
14666 case Ekind (Entity (Orig_N)) is
14667 when E_Constant |
14668 E_Enumeration_Literal |
14669 E_Named_Integer |
14670 E_Named_Real =>
14671 null;
14672 when others =>
14673 if Is_Type (Entity (Orig_N)) then
14674 null;
14675 else
14676 Is_Ok := False;
14677 end if;
14678 end case;
14679 end if;
14680
14681 when N_Qualified_Expression |
14682 N_Type_Conversion =>
14683 Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N));
14684
14685 when N_Unary_Op =>
14686 Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
14687
14688 when N_Binary_Op |
14689 N_Short_Circuit |
14690 N_Membership_Test =>
14691 Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N))
14692 and then
14693 Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
14694
14695 when N_Aggregate |
14696 N_Extension_Aggregate =>
14697 if Nkind (Orig_N) = N_Extension_Aggregate then
14698 Is_Ok :=
14699 Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N));
14700 end if;
14701
14702 Expr := First (Expressions (Orig_N));
14703 while Present (Expr) loop
14704 if not Is_SPARK_05_Initialization_Expr (Expr) then
14705 Is_Ok := False;
14706 goto Done;
14707 end if;
14708
14709 Next (Expr);
14710 end loop;
14711
14712 Comp_Assn := First (Component_Associations (Orig_N));
14713 while Present (Comp_Assn) loop
14714 Expr := Expression (Comp_Assn);
14715
14716 -- Note: test for Present here needed for box assocation
14717
14718 if Present (Expr)
14719 and then not Is_SPARK_05_Initialization_Expr (Expr)
14720 then
14721 Is_Ok := False;
14722 goto Done;
14723 end if;
14724
14725 Next (Comp_Assn);
14726 end loop;
14727
14728 when N_Attribute_Reference =>
14729 if Nkind (Prefix (Orig_N)) in N_Subexpr then
14730 Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N));
14731 end if;
14732
14733 Expr := First (Expressions (Orig_N));
14734 while Present (Expr) loop
14735 if not Is_SPARK_05_Initialization_Expr (Expr) then
14736 Is_Ok := False;
14737 goto Done;
14738 end if;
14739
14740 Next (Expr);
14741 end loop;
14742
14743 -- Selected components might be expanded named not yet resolved, so
14744 -- default on the safe side. (Eg on sparklex.ads)
14745
14746 when N_Selected_Component =>
14747 null;
14748
14749 when others =>
14750 Is_Ok := False;
14751 end case;
14752
14753 <<Done>>
14754 return Is_Ok;
14755 end Is_SPARK_05_Initialization_Expr;
14756
14757 ----------------------------------
14758 -- Is_SPARK_05_Object_Reference --
14759 ----------------------------------
14760
14761 function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is
14762 begin
14763 if Is_Entity_Name (N) then
14764 return Present (Entity (N))
14765 and then
14766 (Ekind_In (Entity (N), E_Constant, E_Variable)
14767 or else Ekind (Entity (N)) in Formal_Kind);
14768
14769 else
14770 case Nkind (N) is
14771 when N_Selected_Component =>
14772 return Is_SPARK_05_Object_Reference (Prefix (N));
14773
14774 when others =>
14775 return False;
14776 end case;
14777 end if;
14778 end Is_SPARK_05_Object_Reference;
14779
14780 -----------------------------
14781 -- Is_Specific_Tagged_Type --
14782 -----------------------------
14783
14784 function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is
14785 Full_Typ : Entity_Id;
14786
14787 begin
14788 -- Handle private types
14789
14790 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
14791 Full_Typ := Full_View (Typ);
14792 else
14793 Full_Typ := Typ;
14794 end if;
14795
14796 -- A specific tagged type is a non-class-wide tagged type
14797
14798 return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ);
14799 end Is_Specific_Tagged_Type;
14800
14801 ------------------
14802 -- Is_Statement --
14803 ------------------
14804
14805 function Is_Statement (N : Node_Id) return Boolean is
14806 begin
14807 return
14808 Nkind (N) in N_Statement_Other_Than_Procedure_Call
14809 or else Nkind (N) = N_Procedure_Call_Statement;
14810 end Is_Statement;
14811
14812 ---------------------------------------
14813 -- Is_Subprogram_Contract_Annotation --
14814 ---------------------------------------
14815
14816 function Is_Subprogram_Contract_Annotation
14817 (Item : Node_Id) return Boolean
14818 is
14819 Nam : Name_Id;
14820
14821 begin
14822 if Nkind (Item) = N_Aspect_Specification then
14823 Nam := Chars (Identifier (Item));
14824
14825 else pragma Assert (Nkind (Item) = N_Pragma);
14826 Nam := Pragma_Name (Item);
14827 end if;
14828
14829 return Nam = Name_Contract_Cases
14830 or else Nam = Name_Depends
14831 or else Nam = Name_Extensions_Visible
14832 or else Nam = Name_Global
14833 or else Nam = Name_Post
14834 or else Nam = Name_Post_Class
14835 or else Nam = Name_Postcondition
14836 or else Nam = Name_Pre
14837 or else Nam = Name_Pre_Class
14838 or else Nam = Name_Precondition
14839 or else Nam = Name_Refined_Depends
14840 or else Nam = Name_Refined_Global
14841 or else Nam = Name_Refined_Post
14842 or else Nam = Name_Test_Case;
14843 end Is_Subprogram_Contract_Annotation;
14844
14845 --------------------------------------------------
14846 -- Is_Subprogram_Stub_Without_Prior_Declaration --
14847 --------------------------------------------------
14848
14849 function Is_Subprogram_Stub_Without_Prior_Declaration
14850 (N : Node_Id) return Boolean
14851 is
14852 begin
14853 -- A subprogram stub without prior declaration serves as declaration for
14854 -- the actual subprogram body. As such, it has an attached defining
14855 -- entity of E_[Generic_]Function or E_[Generic_]Procedure.
14856
14857 return Nkind (N) = N_Subprogram_Body_Stub
14858 and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
14859 end Is_Subprogram_Stub_Without_Prior_Declaration;
14860
14861 --------------------------
14862 -- Is_Suspension_Object --
14863 --------------------------
14864
14865 function Is_Suspension_Object (Id : Entity_Id) return Boolean is
14866 begin
14867 -- This approach does an exact name match rather than to rely on
14868 -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the
14869 -- front end at point where all auxiliary tables are locked and any
14870 -- modifications to them are treated as violations. Do not tamper with
14871 -- the tables, instead examine the Chars fields of all the scopes of Id.
14872
14873 return
14874 Chars (Id) = Name_Suspension_Object
14875 and then Present (Scope (Id))
14876 and then Chars (Scope (Id)) = Name_Synchronous_Task_Control
14877 and then Present (Scope (Scope (Id)))
14878 and then Chars (Scope (Scope (Id))) = Name_Ada
14879 and then Present (Scope (Scope (Scope (Id))))
14880 and then Scope (Scope (Scope (Id))) = Standard_Standard;
14881 end Is_Suspension_Object;
14882
14883 ----------------------------
14884 -- Is_Synchronized_Object --
14885 ----------------------------
14886
14887 function Is_Synchronized_Object (Id : Entity_Id) return Boolean is
14888 Prag : Node_Id;
14889
14890 begin
14891 if Is_Object (Id) then
14892
14893 -- The object is synchronized if it is of a type that yields a
14894 -- synchronized object.
14895
14896 if Yields_Synchronized_Object (Etype (Id)) then
14897 return True;
14898
14899 -- The object is synchronized if it is atomic and Async_Writers is
14900 -- enabled.
14901
14902 elsif Is_Atomic (Id) and then Async_Writers_Enabled (Id) then
14903 return True;
14904
14905 -- A constant is a synchronized object by default
14906
14907 elsif Ekind (Id) = E_Constant then
14908 return True;
14909
14910 -- A variable is a synchronized object if it is subject to pragma
14911 -- Constant_After_Elaboration.
14912
14913 elsif Ekind (Id) = E_Variable then
14914 Prag := Get_Pragma (Id, Pragma_Constant_After_Elaboration);
14915
14916 return Present (Prag) and then Is_Enabled_Pragma (Prag);
14917 end if;
14918 end if;
14919
14920 -- Otherwise the input is not an object or it does not qualify as a
14921 -- synchronized object.
14922
14923 return False;
14924 end Is_Synchronized_Object;
14925
14926 ---------------------------------
14927 -- Is_Synchronized_Tagged_Type --
14928 ---------------------------------
14929
14930 function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
14931 Kind : constant Entity_Kind := Ekind (Base_Type (E));
14932
14933 begin
14934 -- A task or protected type derived from an interface is a tagged type.
14935 -- Such a tagged type is called a synchronized tagged type, as are
14936 -- synchronized interfaces and private extensions whose declaration
14937 -- includes the reserved word synchronized.
14938
14939 return (Is_Tagged_Type (E)
14940 and then (Kind = E_Task_Type
14941 or else
14942 Kind = E_Protected_Type))
14943 or else
14944 (Is_Interface (E)
14945 and then Is_Synchronized_Interface (E))
14946 or else
14947 (Ekind (E) = E_Record_Type_With_Private
14948 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
14949 and then (Synchronized_Present (Parent (E))
14950 or else Is_Synchronized_Interface (Etype (E))));
14951 end Is_Synchronized_Tagged_Type;
14952
14953 -----------------
14954 -- Is_Transfer --
14955 -----------------
14956
14957 function Is_Transfer (N : Node_Id) return Boolean is
14958 Kind : constant Node_Kind := Nkind (N);
14959
14960 begin
14961 if Kind = N_Simple_Return_Statement
14962 or else
14963 Kind = N_Extended_Return_Statement
14964 or else
14965 Kind = N_Goto_Statement
14966 or else
14967 Kind = N_Raise_Statement
14968 or else
14969 Kind = N_Requeue_Statement
14970 then
14971 return True;
14972
14973 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
14974 and then No (Condition (N))
14975 then
14976 return True;
14977
14978 elsif Kind = N_Procedure_Call_Statement
14979 and then Is_Entity_Name (Name (N))
14980 and then Present (Entity (Name (N)))
14981 and then No_Return (Entity (Name (N)))
14982 then
14983 return True;
14984
14985 elsif Nkind (Original_Node (N)) = N_Raise_Statement then
14986 return True;
14987
14988 else
14989 return False;
14990 end if;
14991 end Is_Transfer;
14992
14993 -------------
14994 -- Is_True --
14995 -------------
14996
14997 function Is_True (U : Uint) return Boolean is
14998 begin
14999 return (U /= 0);
15000 end Is_True;
15001
15002 --------------------------------------
15003 -- Is_Unchecked_Conversion_Instance --
15004 --------------------------------------
15005
15006 function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is
15007 Par : Node_Id;
15008
15009 begin
15010 -- Look for a function whose generic parent is the predefined intrinsic
15011 -- function Unchecked_Conversion, or for one that renames such an
15012 -- instance.
15013
15014 if Ekind (Id) = E_Function then
15015 Par := Parent (Id);
15016
15017 if Nkind (Par) = N_Function_Specification then
15018 Par := Generic_Parent (Par);
15019
15020 if Present (Par) then
15021 return
15022 Chars (Par) = Name_Unchecked_Conversion
15023 and then Is_Intrinsic_Subprogram (Par)
15024 and then Is_Predefined_File_Name
15025 (Unit_File_Name (Get_Source_Unit (Par)));
15026 else
15027 return
15028 Present (Alias (Id))
15029 and then Is_Unchecked_Conversion_Instance (Alias (Id));
15030 end if;
15031 end if;
15032 end if;
15033
15034 return False;
15035 end Is_Unchecked_Conversion_Instance;
15036
15037 -------------------------------
15038 -- Is_Universal_Numeric_Type --
15039 -------------------------------
15040
15041 function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
15042 begin
15043 return T = Universal_Integer or else T = Universal_Real;
15044 end Is_Universal_Numeric_Type;
15045
15046 ----------------------------
15047 -- Is_Variable_Size_Array --
15048 ----------------------------
15049
15050 function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
15051 Idx : Node_Id;
15052
15053 begin
15054 pragma Assert (Is_Array_Type (E));
15055
15056 -- Check if some index is initialized with a non-constant value
15057
15058 Idx := First_Index (E);
15059 while Present (Idx) loop
15060 if Nkind (Idx) = N_Range then
15061 if not Is_Constant_Bound (Low_Bound (Idx))
15062 or else not Is_Constant_Bound (High_Bound (Idx))
15063 then
15064 return True;
15065 end if;
15066 end if;
15067
15068 Idx := Next_Index (Idx);
15069 end loop;
15070
15071 return False;
15072 end Is_Variable_Size_Array;
15073
15074 -----------------------------
15075 -- Is_Variable_Size_Record --
15076 -----------------------------
15077
15078 function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
15079 Comp : Entity_Id;
15080 Comp_Typ : Entity_Id;
15081
15082 begin
15083 pragma Assert (Is_Record_Type (E));
15084
15085 Comp := First_Entity (E);
15086 while Present (Comp) loop
15087 Comp_Typ := Etype (Comp);
15088
15089 -- Recursive call if the record type has discriminants
15090
15091 if Is_Record_Type (Comp_Typ)
15092 and then Has_Discriminants (Comp_Typ)
15093 and then Is_Variable_Size_Record (Comp_Typ)
15094 then
15095 return True;
15096
15097 elsif Is_Array_Type (Comp_Typ)
15098 and then Is_Variable_Size_Array (Comp_Typ)
15099 then
15100 return True;
15101 end if;
15102
15103 Next_Entity (Comp);
15104 end loop;
15105
15106 return False;
15107 end Is_Variable_Size_Record;
15108
15109 -----------------
15110 -- Is_Variable --
15111 -----------------
15112
15113 function Is_Variable
15114 (N : Node_Id;
15115 Use_Original_Node : Boolean := True) return Boolean
15116 is
15117 Orig_Node : Node_Id;
15118
15119 function In_Protected_Function (E : Entity_Id) return Boolean;
15120 -- Within a protected function, the private components of the enclosing
15121 -- protected type are constants. A function nested within a (protected)
15122 -- procedure is not itself protected. Within the body of a protected
15123 -- function the current instance of the protected type is a constant.
15124
15125 function Is_Variable_Prefix (P : Node_Id) return Boolean;
15126 -- Prefixes can involve implicit dereferences, in which case we must
15127 -- test for the case of a reference of a constant access type, which can
15128 -- can never be a variable.
15129
15130 ---------------------------
15131 -- In_Protected_Function --
15132 ---------------------------
15133
15134 function In_Protected_Function (E : Entity_Id) return Boolean is
15135 Prot : Entity_Id;
15136 S : Entity_Id;
15137
15138 begin
15139 -- E is the current instance of a type
15140
15141 if Is_Type (E) then
15142 Prot := E;
15143
15144 -- E is an object
15145
15146 else
15147 Prot := Scope (E);
15148 end if;
15149
15150 if not Is_Protected_Type (Prot) then
15151 return False;
15152
15153 else
15154 S := Current_Scope;
15155 while Present (S) and then S /= Prot loop
15156 if Ekind (S) = E_Function and then Scope (S) = Prot then
15157 return True;
15158 end if;
15159
15160 S := Scope (S);
15161 end loop;
15162
15163 return False;
15164 end if;
15165 end In_Protected_Function;
15166
15167 ------------------------
15168 -- Is_Variable_Prefix --
15169 ------------------------
15170
15171 function Is_Variable_Prefix (P : Node_Id) return Boolean is
15172 begin
15173 if Is_Access_Type (Etype (P)) then
15174 return not Is_Access_Constant (Root_Type (Etype (P)));
15175
15176 -- For the case of an indexed component whose prefix has a packed
15177 -- array type, the prefix has been rewritten into a type conversion.
15178 -- Determine variable-ness from the converted expression.
15179
15180 elsif Nkind (P) = N_Type_Conversion
15181 and then not Comes_From_Source (P)
15182 and then Is_Array_Type (Etype (P))
15183 and then Is_Packed (Etype (P))
15184 then
15185 return Is_Variable (Expression (P));
15186
15187 else
15188 return Is_Variable (P);
15189 end if;
15190 end Is_Variable_Prefix;
15191
15192 -- Start of processing for Is_Variable
15193
15194 begin
15195 -- Special check, allow x'Deref(expr) as a variable
15196
15197 if Nkind (N) = N_Attribute_Reference
15198 and then Attribute_Name (N) = Name_Deref
15199 then
15200 return True;
15201 end if;
15202
15203 -- Check if we perform the test on the original node since this may be a
15204 -- test of syntactic categories which must not be disturbed by whatever
15205 -- rewriting might have occurred. For example, an aggregate, which is
15206 -- certainly NOT a variable, could be turned into a variable by
15207 -- expansion.
15208
15209 if Use_Original_Node then
15210 Orig_Node := Original_Node (N);
15211 else
15212 Orig_Node := N;
15213 end if;
15214
15215 -- Definitely OK if Assignment_OK is set. Since this is something that
15216 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
15217
15218 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
15219 return True;
15220
15221 -- Normally we go to the original node, but there is one exception where
15222 -- we use the rewritten node, namely when it is an explicit dereference.
15223 -- The generated code may rewrite a prefix which is an access type with
15224 -- an explicit dereference. The dereference is a variable, even though
15225 -- the original node may not be (since it could be a constant of the
15226 -- access type).
15227
15228 -- In Ada 2005 we have a further case to consider: the prefix may be a
15229 -- function call given in prefix notation. The original node appears to
15230 -- be a selected component, but we need to examine the call.
15231
15232 elsif Nkind (N) = N_Explicit_Dereference
15233 and then Nkind (Orig_Node) /= N_Explicit_Dereference
15234 and then Present (Etype (Orig_Node))
15235 and then Is_Access_Type (Etype (Orig_Node))
15236 then
15237 -- Note that if the prefix is an explicit dereference that does not
15238 -- come from source, we must check for a rewritten function call in
15239 -- prefixed notation before other forms of rewriting, to prevent a
15240 -- compiler crash.
15241
15242 return
15243 (Nkind (Orig_Node) = N_Function_Call
15244 and then not Is_Access_Constant (Etype (Prefix (N))))
15245 or else
15246 Is_Variable_Prefix (Original_Node (Prefix (N)));
15247
15248 -- in Ada 2012, the dereference may have been added for a type with
15249 -- a declared implicit dereference aspect. Check that it is not an
15250 -- access to constant.
15251
15252 elsif Nkind (N) = N_Explicit_Dereference
15253 and then Present (Etype (Orig_Node))
15254 and then Ada_Version >= Ada_2012
15255 and then Has_Implicit_Dereference (Etype (Orig_Node))
15256 then
15257 return not Is_Access_Constant (Etype (Prefix (N)));
15258
15259 -- A function call is never a variable
15260
15261 elsif Nkind (N) = N_Function_Call then
15262 return False;
15263
15264 -- All remaining checks use the original node
15265
15266 elsif Is_Entity_Name (Orig_Node)
15267 and then Present (Entity (Orig_Node))
15268 then
15269 declare
15270 E : constant Entity_Id := Entity (Orig_Node);
15271 K : constant Entity_Kind := Ekind (E);
15272
15273 begin
15274 return (K = E_Variable
15275 and then Nkind (Parent (E)) /= N_Exception_Handler)
15276 or else (K = E_Component
15277 and then not In_Protected_Function (E))
15278 or else K = E_Out_Parameter
15279 or else K = E_In_Out_Parameter
15280 or else K = E_Generic_In_Out_Parameter
15281
15282 -- Current instance of type. If this is a protected type, check
15283 -- we are not within the body of one of its protected functions.
15284
15285 or else (Is_Type (E)
15286 and then In_Open_Scopes (E)
15287 and then not In_Protected_Function (E))
15288
15289 or else (Is_Incomplete_Or_Private_Type (E)
15290 and then In_Open_Scopes (Full_View (E)));
15291 end;
15292
15293 else
15294 case Nkind (Orig_Node) is
15295 when N_Indexed_Component | N_Slice =>
15296 return Is_Variable_Prefix (Prefix (Orig_Node));
15297
15298 when N_Selected_Component =>
15299 return (Is_Variable (Selector_Name (Orig_Node))
15300 and then Is_Variable_Prefix (Prefix (Orig_Node)))
15301 or else
15302 (Nkind (N) = N_Expanded_Name
15303 and then Scope (Entity (N)) = Entity (Prefix (N)));
15304
15305 -- For an explicit dereference, the type of the prefix cannot
15306 -- be an access to constant or an access to subprogram.
15307
15308 when N_Explicit_Dereference =>
15309 declare
15310 Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
15311 begin
15312 return Is_Access_Type (Typ)
15313 and then not Is_Access_Constant (Root_Type (Typ))
15314 and then Ekind (Typ) /= E_Access_Subprogram_Type;
15315 end;
15316
15317 -- The type conversion is the case where we do not deal with the
15318 -- context dependent special case of an actual parameter. Thus
15319 -- the type conversion is only considered a variable for the
15320 -- purposes of this routine if the target type is tagged. However,
15321 -- a type conversion is considered to be a variable if it does not
15322 -- come from source (this deals for example with the conversions
15323 -- of expressions to their actual subtypes).
15324
15325 when N_Type_Conversion =>
15326 return Is_Variable (Expression (Orig_Node))
15327 and then
15328 (not Comes_From_Source (Orig_Node)
15329 or else
15330 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
15331 and then
15332 Is_Tagged_Type (Etype (Expression (Orig_Node)))));
15333
15334 -- GNAT allows an unchecked type conversion as a variable. This
15335 -- only affects the generation of internal expanded code, since
15336 -- calls to instantiations of Unchecked_Conversion are never
15337 -- considered variables (since they are function calls).
15338
15339 when N_Unchecked_Type_Conversion =>
15340 return Is_Variable (Expression (Orig_Node));
15341
15342 when others =>
15343 return False;
15344 end case;
15345 end if;
15346 end Is_Variable;
15347
15348 ---------------------------
15349 -- Is_Visibly_Controlled --
15350 ---------------------------
15351
15352 function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
15353 Root : constant Entity_Id := Root_Type (T);
15354 begin
15355 return Chars (Scope (Root)) = Name_Finalization
15356 and then Chars (Scope (Scope (Root))) = Name_Ada
15357 and then Scope (Scope (Scope (Root))) = Standard_Standard;
15358 end Is_Visibly_Controlled;
15359
15360 --------------------------
15361 -- Is_Volatile_Function --
15362 --------------------------
15363
15364 function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is
15365 begin
15366 pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function));
15367
15368 -- A function declared within a protected type is volatile
15369
15370 if Is_Protected_Type (Scope (Func_Id)) then
15371 return True;
15372
15373 -- An instance of Ada.Unchecked_Conversion is a volatile function if
15374 -- either the source or the target are effectively volatile.
15375
15376 elsif Is_Unchecked_Conversion_Instance (Func_Id)
15377 and then Has_Effectively_Volatile_Profile (Func_Id)
15378 then
15379 return True;
15380
15381 -- Otherwise the function is treated as volatile if it is subject to
15382 -- enabled pragma Volatile_Function.
15383
15384 else
15385 return
15386 Is_Enabled_Pragma (Get_Pragma (Func_Id, Pragma_Volatile_Function));
15387 end if;
15388 end Is_Volatile_Function;
15389
15390 ------------------------
15391 -- Is_Volatile_Object --
15392 ------------------------
15393
15394 function Is_Volatile_Object (N : Node_Id) return Boolean is
15395
15396 function Is_Volatile_Prefix (N : Node_Id) return Boolean;
15397 -- If prefix is an implicit dereference, examine designated type
15398
15399 function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
15400 -- Determines if given object has volatile components
15401
15402 ------------------------
15403 -- Is_Volatile_Prefix --
15404 ------------------------
15405
15406 function Is_Volatile_Prefix (N : Node_Id) return Boolean is
15407 Typ : constant Entity_Id := Etype (N);
15408
15409 begin
15410 if Is_Access_Type (Typ) then
15411 declare
15412 Dtyp : constant Entity_Id := Designated_Type (Typ);
15413
15414 begin
15415 return Is_Volatile (Dtyp)
15416 or else Has_Volatile_Components (Dtyp);
15417 end;
15418
15419 else
15420 return Object_Has_Volatile_Components (N);
15421 end if;
15422 end Is_Volatile_Prefix;
15423
15424 ------------------------------------
15425 -- Object_Has_Volatile_Components --
15426 ------------------------------------
15427
15428 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
15429 Typ : constant Entity_Id := Etype (N);
15430
15431 begin
15432 if Is_Volatile (Typ)
15433 or else Has_Volatile_Components (Typ)
15434 then
15435 return True;
15436
15437 elsif Is_Entity_Name (N)
15438 and then (Has_Volatile_Components (Entity (N))
15439 or else Is_Volatile (Entity (N)))
15440 then
15441 return True;
15442
15443 elsif Nkind (N) = N_Indexed_Component
15444 or else Nkind (N) = N_Selected_Component
15445 then
15446 return Is_Volatile_Prefix (Prefix (N));
15447
15448 else
15449 return False;
15450 end if;
15451 end Object_Has_Volatile_Components;
15452
15453 -- Start of processing for Is_Volatile_Object
15454
15455 begin
15456 if Nkind (N) = N_Defining_Identifier then
15457 return Is_Volatile (N) or else Is_Volatile (Etype (N));
15458
15459 elsif Nkind (N) = N_Expanded_Name then
15460 return Is_Volatile_Object (Entity (N));
15461
15462 elsif Is_Volatile (Etype (N))
15463 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
15464 then
15465 return True;
15466
15467 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
15468 and then Is_Volatile_Prefix (Prefix (N))
15469 then
15470 return True;
15471
15472 elsif Nkind (N) = N_Selected_Component
15473 and then Is_Volatile (Entity (Selector_Name (N)))
15474 then
15475 return True;
15476
15477 else
15478 return False;
15479 end if;
15480 end Is_Volatile_Object;
15481
15482 ---------------------------
15483 -- Itype_Has_Declaration --
15484 ---------------------------
15485
15486 function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
15487 begin
15488 pragma Assert (Is_Itype (Id));
15489 return Present (Parent (Id))
15490 and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
15491 N_Subtype_Declaration)
15492 and then Defining_Entity (Parent (Id)) = Id;
15493 end Itype_Has_Declaration;
15494
15495 -------------------------
15496 -- Kill_Current_Values --
15497 -------------------------
15498
15499 procedure Kill_Current_Values
15500 (Ent : Entity_Id;
15501 Last_Assignment_Only : Boolean := False)
15502 is
15503 begin
15504 if Is_Assignable (Ent) then
15505 Set_Last_Assignment (Ent, Empty);
15506 end if;
15507
15508 if Is_Object (Ent) then
15509 if not Last_Assignment_Only then
15510 Kill_Checks (Ent);
15511 Set_Current_Value (Ent, Empty);
15512
15513 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
15514 -- for a constant. Once the constant is elaborated, its value is
15515 -- not changed, therefore the associated flags that describe the
15516 -- value should not be modified either.
15517
15518 if Ekind (Ent) = E_Constant then
15519 null;
15520
15521 -- Non-constant entities
15522
15523 else
15524 if not Can_Never_Be_Null (Ent) then
15525 Set_Is_Known_Non_Null (Ent, False);
15526 end if;
15527
15528 Set_Is_Known_Null (Ent, False);
15529
15530 -- Reset the Is_Known_Valid flag unless the type is always
15531 -- valid. This does not apply to a loop parameter because its
15532 -- bounds are defined by the loop header and therefore always
15533 -- valid.
15534
15535 if not Is_Known_Valid (Etype (Ent))
15536 and then Ekind (Ent) /= E_Loop_Parameter
15537 then
15538 Set_Is_Known_Valid (Ent, False);
15539 end if;
15540 end if;
15541 end if;
15542 end if;
15543 end Kill_Current_Values;
15544
15545 procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
15546 S : Entity_Id;
15547
15548 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
15549 -- Clear current value for entity E and all entities chained to E
15550
15551 ------------------------------------------
15552 -- Kill_Current_Values_For_Entity_Chain --
15553 ------------------------------------------
15554
15555 procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
15556 Ent : Entity_Id;
15557 begin
15558 Ent := E;
15559 while Present (Ent) loop
15560 Kill_Current_Values (Ent, Last_Assignment_Only);
15561 Next_Entity (Ent);
15562 end loop;
15563 end Kill_Current_Values_For_Entity_Chain;
15564
15565 -- Start of processing for Kill_Current_Values
15566
15567 begin
15568 -- Kill all saved checks, a special case of killing saved values
15569
15570 if not Last_Assignment_Only then
15571 Kill_All_Checks;
15572 end if;
15573
15574 -- Loop through relevant scopes, which includes the current scope and
15575 -- any parent scopes if the current scope is a block or a package.
15576
15577 S := Current_Scope;
15578 Scope_Loop : loop
15579
15580 -- Clear current values of all entities in current scope
15581
15582 Kill_Current_Values_For_Entity_Chain (First_Entity (S));
15583
15584 -- If scope is a package, also clear current values of all private
15585 -- entities in the scope.
15586
15587 if Is_Package_Or_Generic_Package (S)
15588 or else Is_Concurrent_Type (S)
15589 then
15590 Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
15591 end if;
15592
15593 -- If this is a not a subprogram, deal with parents
15594
15595 if not Is_Subprogram (S) then
15596 S := Scope (S);
15597 exit Scope_Loop when S = Standard_Standard;
15598 else
15599 exit Scope_Loop;
15600 end if;
15601 end loop Scope_Loop;
15602 end Kill_Current_Values;
15603
15604 --------------------------
15605 -- Kill_Size_Check_Code --
15606 --------------------------
15607
15608 procedure Kill_Size_Check_Code (E : Entity_Id) is
15609 begin
15610 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
15611 and then Present (Size_Check_Code (E))
15612 then
15613 Remove (Size_Check_Code (E));
15614 Set_Size_Check_Code (E, Empty);
15615 end if;
15616 end Kill_Size_Check_Code;
15617
15618 --------------------------
15619 -- Known_To_Be_Assigned --
15620 --------------------------
15621
15622 function Known_To_Be_Assigned (N : Node_Id) return Boolean is
15623 P : constant Node_Id := Parent (N);
15624
15625 begin
15626 case Nkind (P) is
15627
15628 -- Test left side of assignment
15629
15630 when N_Assignment_Statement =>
15631 return N = Name (P);
15632
15633 -- Function call arguments are never lvalues
15634
15635 when N_Function_Call =>
15636 return False;
15637
15638 -- Positional parameter for procedure or accept call
15639
15640 when N_Procedure_Call_Statement |
15641 N_Accept_Statement
15642 =>
15643 declare
15644 Proc : Entity_Id;
15645 Form : Entity_Id;
15646 Act : Node_Id;
15647
15648 begin
15649 Proc := Get_Subprogram_Entity (P);
15650
15651 if No (Proc) then
15652 return False;
15653 end if;
15654
15655 -- If we are not a list member, something is strange, so
15656 -- be conservative and return False.
15657
15658 if not Is_List_Member (N) then
15659 return False;
15660 end if;
15661
15662 -- We are going to find the right formal by stepping forward
15663 -- through the formals, as we step backwards in the actuals.
15664
15665 Form := First_Formal (Proc);
15666 Act := N;
15667 loop
15668 -- If no formal, something is weird, so be conservative
15669 -- and return False.
15670
15671 if No (Form) then
15672 return False;
15673 end if;
15674
15675 Prev (Act);
15676 exit when No (Act);
15677 Next_Formal (Form);
15678 end loop;
15679
15680 return Ekind (Form) /= E_In_Parameter;
15681 end;
15682
15683 -- Named parameter for procedure or accept call
15684
15685 when N_Parameter_Association =>
15686 declare
15687 Proc : Entity_Id;
15688 Form : Entity_Id;
15689
15690 begin
15691 Proc := Get_Subprogram_Entity (Parent (P));
15692
15693 if No (Proc) then
15694 return False;
15695 end if;
15696
15697 -- Loop through formals to find the one that matches
15698
15699 Form := First_Formal (Proc);
15700 loop
15701 -- If no matching formal, that's peculiar, some kind of
15702 -- previous error, so return False to be conservative.
15703 -- Actually this also happens in legal code in the case
15704 -- where P is a parameter association for an Extra_Formal???
15705
15706 if No (Form) then
15707 return False;
15708 end if;
15709
15710 -- Else test for match
15711
15712 if Chars (Form) = Chars (Selector_Name (P)) then
15713 return Ekind (Form) /= E_In_Parameter;
15714 end if;
15715
15716 Next_Formal (Form);
15717 end loop;
15718 end;
15719
15720 -- Test for appearing in a conversion that itself appears
15721 -- in an lvalue context, since this should be an lvalue.
15722
15723 when N_Type_Conversion =>
15724 return Known_To_Be_Assigned (P);
15725
15726 -- All other references are definitely not known to be modifications
15727
15728 when others =>
15729 return False;
15730
15731 end case;
15732 end Known_To_Be_Assigned;
15733
15734 ---------------------------
15735 -- Last_Source_Statement --
15736 ---------------------------
15737
15738 function Last_Source_Statement (HSS : Node_Id) return Node_Id is
15739 N : Node_Id;
15740
15741 begin
15742 N := Last (Statements (HSS));
15743 while Present (N) loop
15744 exit when Comes_From_Source (N);
15745 Prev (N);
15746 end loop;
15747
15748 return N;
15749 end Last_Source_Statement;
15750
15751 ----------------------------------
15752 -- Matching_Static_Array_Bounds --
15753 ----------------------------------
15754
15755 function Matching_Static_Array_Bounds
15756 (L_Typ : Node_Id;
15757 R_Typ : Node_Id) return Boolean
15758 is
15759 L_Ndims : constant Nat := Number_Dimensions (L_Typ);
15760 R_Ndims : constant Nat := Number_Dimensions (R_Typ);
15761
15762 L_Index : Node_Id;
15763 R_Index : Node_Id;
15764 L_Low : Node_Id;
15765 L_High : Node_Id;
15766 L_Len : Uint;
15767 R_Low : Node_Id;
15768 R_High : Node_Id;
15769 R_Len : Uint;
15770
15771 begin
15772 if L_Ndims /= R_Ndims then
15773 return False;
15774 end if;
15775
15776 -- Unconstrained types do not have static bounds
15777
15778 if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
15779 return False;
15780 end if;
15781
15782 -- First treat specially the first dimension, as the lower bound and
15783 -- length of string literals are not stored like those of arrays.
15784
15785 if Ekind (L_Typ) = E_String_Literal_Subtype then
15786 L_Low := String_Literal_Low_Bound (L_Typ);
15787 L_Len := String_Literal_Length (L_Typ);
15788 else
15789 L_Index := First_Index (L_Typ);
15790 Get_Index_Bounds (L_Index, L_Low, L_High);
15791
15792 if Is_OK_Static_Expression (L_Low)
15793 and then
15794 Is_OK_Static_Expression (L_High)
15795 then
15796 if Expr_Value (L_High) < Expr_Value (L_Low) then
15797 L_Len := Uint_0;
15798 else
15799 L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
15800 end if;
15801 else
15802 return False;
15803 end if;
15804 end if;
15805
15806 if Ekind (R_Typ) = E_String_Literal_Subtype then
15807 R_Low := String_Literal_Low_Bound (R_Typ);
15808 R_Len := String_Literal_Length (R_Typ);
15809 else
15810 R_Index := First_Index (R_Typ);
15811 Get_Index_Bounds (R_Index, R_Low, R_High);
15812
15813 if Is_OK_Static_Expression (R_Low)
15814 and then
15815 Is_OK_Static_Expression (R_High)
15816 then
15817 if Expr_Value (R_High) < Expr_Value (R_Low) then
15818 R_Len := Uint_0;
15819 else
15820 R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
15821 end if;
15822 else
15823 return False;
15824 end if;
15825 end if;
15826
15827 if (Is_OK_Static_Expression (L_Low)
15828 and then
15829 Is_OK_Static_Expression (R_Low))
15830 and then Expr_Value (L_Low) = Expr_Value (R_Low)
15831 and then L_Len = R_Len
15832 then
15833 null;
15834 else
15835 return False;
15836 end if;
15837
15838 -- Then treat all other dimensions
15839
15840 for Indx in 2 .. L_Ndims loop
15841 Next (L_Index);
15842 Next (R_Index);
15843
15844 Get_Index_Bounds (L_Index, L_Low, L_High);
15845 Get_Index_Bounds (R_Index, R_Low, R_High);
15846
15847 if (Is_OK_Static_Expression (L_Low) and then
15848 Is_OK_Static_Expression (L_High) and then
15849 Is_OK_Static_Expression (R_Low) and then
15850 Is_OK_Static_Expression (R_High))
15851 and then (Expr_Value (L_Low) = Expr_Value (R_Low)
15852 and then
15853 Expr_Value (L_High) = Expr_Value (R_High))
15854 then
15855 null;
15856 else
15857 return False;
15858 end if;
15859 end loop;
15860
15861 -- If we fall through the loop, all indexes matched
15862
15863 return True;
15864 end Matching_Static_Array_Bounds;
15865
15866 -------------------
15867 -- May_Be_Lvalue --
15868 -------------------
15869
15870 function May_Be_Lvalue (N : Node_Id) return Boolean is
15871 P : constant Node_Id := Parent (N);
15872
15873 begin
15874 case Nkind (P) is
15875
15876 -- Test left side of assignment
15877
15878 when N_Assignment_Statement =>
15879 return N = Name (P);
15880
15881 -- Test prefix of component or attribute. Note that the prefix of an
15882 -- explicit or implicit dereference cannot be an l-value. In the case
15883 -- of a 'Read attribute, the reference can be an actual in the
15884 -- argument list of the attribute.
15885
15886 when N_Attribute_Reference =>
15887 return (N = Prefix (P)
15888 and then Name_Implies_Lvalue_Prefix (Attribute_Name (P)))
15889 or else
15890 Attribute_Name (P) = Name_Read;
15891
15892 -- For an expanded name, the name is an lvalue if the expanded name
15893 -- is an lvalue, but the prefix is never an lvalue, since it is just
15894 -- the scope where the name is found.
15895
15896 when N_Expanded_Name =>
15897 if N = Prefix (P) then
15898 return May_Be_Lvalue (P);
15899 else
15900 return False;
15901 end if;
15902
15903 -- For a selected component A.B, A is certainly an lvalue if A.B is.
15904 -- B is a little interesting, if we have A.B := 3, there is some
15905 -- discussion as to whether B is an lvalue or not, we choose to say
15906 -- it is. Note however that A is not an lvalue if it is of an access
15907 -- type since this is an implicit dereference.
15908
15909 when N_Selected_Component =>
15910 if N = Prefix (P)
15911 and then Present (Etype (N))
15912 and then Is_Access_Type (Etype (N))
15913 then
15914 return False;
15915 else
15916 return May_Be_Lvalue (P);
15917 end if;
15918
15919 -- For an indexed component or slice, the index or slice bounds is
15920 -- never an lvalue. The prefix is an lvalue if the indexed component
15921 -- or slice is an lvalue, except if it is an access type, where we
15922 -- have an implicit dereference.
15923
15924 when N_Indexed_Component | N_Slice =>
15925 if N /= Prefix (P)
15926 or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
15927 then
15928 return False;
15929 else
15930 return May_Be_Lvalue (P);
15931 end if;
15932
15933 -- Prefix of a reference is an lvalue if the reference is an lvalue
15934
15935 when N_Reference =>
15936 return May_Be_Lvalue (P);
15937
15938 -- Prefix of explicit dereference is never an lvalue
15939
15940 when N_Explicit_Dereference =>
15941 return False;
15942
15943 -- Positional parameter for subprogram, entry, or accept call.
15944 -- In older versions of Ada function call arguments are never
15945 -- lvalues. In Ada 2012 functions can have in-out parameters.
15946
15947 when N_Subprogram_Call |
15948 N_Entry_Call_Statement |
15949 N_Accept_Statement
15950 =>
15951 if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
15952 return False;
15953 end if;
15954
15955 -- The following mechanism is clumsy and fragile. A single flag
15956 -- set in Resolve_Actuals would be preferable ???
15957
15958 declare
15959 Proc : Entity_Id;
15960 Form : Entity_Id;
15961 Act : Node_Id;
15962
15963 begin
15964 Proc := Get_Subprogram_Entity (P);
15965
15966 if No (Proc) then
15967 return True;
15968 end if;
15969
15970 -- If we are not a list member, something is strange, so be
15971 -- conservative and return True.
15972
15973 if not Is_List_Member (N) then
15974 return True;
15975 end if;
15976
15977 -- We are going to find the right formal by stepping forward
15978 -- through the formals, as we step backwards in the actuals.
15979
15980 Form := First_Formal (Proc);
15981 Act := N;
15982 loop
15983 -- If no formal, something is weird, so be conservative and
15984 -- return True.
15985
15986 if No (Form) then
15987 return True;
15988 end if;
15989
15990 Prev (Act);
15991 exit when No (Act);
15992 Next_Formal (Form);
15993 end loop;
15994
15995 return Ekind (Form) /= E_In_Parameter;
15996 end;
15997
15998 -- Named parameter for procedure or accept call
15999
16000 when N_Parameter_Association =>
16001 declare
16002 Proc : Entity_Id;
16003 Form : Entity_Id;
16004
16005 begin
16006 Proc := Get_Subprogram_Entity (Parent (P));
16007
16008 if No (Proc) then
16009 return True;
16010 end if;
16011
16012 -- Loop through formals to find the one that matches
16013
16014 Form := First_Formal (Proc);
16015 loop
16016 -- If no matching formal, that's peculiar, some kind of
16017 -- previous error, so return True to be conservative.
16018 -- Actually happens with legal code for an unresolved call
16019 -- where we may get the wrong homonym???
16020
16021 if No (Form) then
16022 return True;
16023 end if;
16024
16025 -- Else test for match
16026
16027 if Chars (Form) = Chars (Selector_Name (P)) then
16028 return Ekind (Form) /= E_In_Parameter;
16029 end if;
16030
16031 Next_Formal (Form);
16032 end loop;
16033 end;
16034
16035 -- Test for appearing in a conversion that itself appears in an
16036 -- lvalue context, since this should be an lvalue.
16037
16038 when N_Type_Conversion =>
16039 return May_Be_Lvalue (P);
16040
16041 -- Test for appearance in object renaming declaration
16042
16043 when N_Object_Renaming_Declaration =>
16044 return True;
16045
16046 -- All other references are definitely not lvalues
16047
16048 when others =>
16049 return False;
16050
16051 end case;
16052 end May_Be_Lvalue;
16053
16054 -----------------------
16055 -- Mark_Coextensions --
16056 -----------------------
16057
16058 procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
16059 Is_Dynamic : Boolean;
16060 -- Indicates whether the context causes nested coextensions to be
16061 -- dynamic or static
16062
16063 function Mark_Allocator (N : Node_Id) return Traverse_Result;
16064 -- Recognize an allocator node and label it as a dynamic coextension
16065
16066 --------------------
16067 -- Mark_Allocator --
16068 --------------------
16069
16070 function Mark_Allocator (N : Node_Id) return Traverse_Result is
16071 begin
16072 if Nkind (N) = N_Allocator then
16073 if Is_Dynamic then
16074 Set_Is_Dynamic_Coextension (N);
16075
16076 -- If the allocator expression is potentially dynamic, it may
16077 -- be expanded out of order and require dynamic allocation
16078 -- anyway, so we treat the coextension itself as dynamic.
16079 -- Potential optimization ???
16080
16081 elsif Nkind (Expression (N)) = N_Qualified_Expression
16082 and then Nkind (Expression (Expression (N))) = N_Op_Concat
16083 then
16084 Set_Is_Dynamic_Coextension (N);
16085 else
16086 Set_Is_Static_Coextension (N);
16087 end if;
16088 end if;
16089
16090 return OK;
16091 end Mark_Allocator;
16092
16093 procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
16094
16095 -- Start of processing for Mark_Coextensions
16096
16097 begin
16098 -- An allocator that appears on the right-hand side of an assignment is
16099 -- treated as a potentially dynamic coextension when the right-hand side
16100 -- is an allocator or a qualified expression.
16101
16102 -- Obj := new ...'(new Coextension ...);
16103
16104 if Nkind (Context_Nod) = N_Assignment_Statement then
16105 Is_Dynamic :=
16106 Nkind_In (Expression (Context_Nod), N_Allocator,
16107 N_Qualified_Expression);
16108
16109 -- An allocator that appears within the expression of a simple return
16110 -- statement is treated as a potentially dynamic coextension when the
16111 -- expression is either aggregate, allocator, or qualified expression.
16112
16113 -- return (new Coextension ...);
16114 -- return new ...'(new Coextension ...);
16115
16116 elsif Nkind (Context_Nod) = N_Simple_Return_Statement then
16117 Is_Dynamic :=
16118 Nkind_In (Expression (Context_Nod), N_Aggregate,
16119 N_Allocator,
16120 N_Qualified_Expression);
16121
16122 -- An alloctor that appears within the initialization expression of an
16123 -- object declaration is considered a potentially dynamic coextension
16124 -- when the initialization expression is an allocator or a qualified
16125 -- expression.
16126
16127 -- Obj : ... := new ...'(new Coextension ...);
16128
16129 -- A similar case arises when the object declaration is part of an
16130 -- extended return statement.
16131
16132 -- return Obj : ... := new ...'(new Coextension ...);
16133 -- return Obj : ... := (new Coextension ...);
16134
16135 elsif Nkind (Context_Nod) = N_Object_Declaration then
16136 Is_Dynamic :=
16137 Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression)
16138 or else
16139 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
16140
16141 -- This routine should not be called with constructs that cannot contain
16142 -- coextensions.
16143
16144 else
16145 raise Program_Error;
16146 end if;
16147
16148 Mark_Allocators (Root_Nod);
16149 end Mark_Coextensions;
16150
16151 ----------------------
16152 -- Needs_One_Actual --
16153 ----------------------
16154
16155 function Needs_One_Actual (E : Entity_Id) return Boolean is
16156 Formal : Entity_Id;
16157
16158 begin
16159 -- Ada 2005 or later, and formals present
16160
16161 if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then
16162 Formal := Next_Formal (First_Formal (E));
16163 while Present (Formal) loop
16164 if No (Default_Value (Formal)) then
16165 return False;
16166 end if;
16167
16168 Next_Formal (Formal);
16169 end loop;
16170
16171 return True;
16172
16173 -- Ada 83/95 or no formals
16174
16175 else
16176 return False;
16177 end if;
16178 end Needs_One_Actual;
16179
16180 ------------------------
16181 -- New_Copy_List_Tree --
16182 ------------------------
16183
16184 function New_Copy_List_Tree (List : List_Id) return List_Id is
16185 NL : List_Id;
16186 E : Node_Id;
16187
16188 begin
16189 if List = No_List then
16190 return No_List;
16191
16192 else
16193 NL := New_List;
16194 E := First (List);
16195
16196 while Present (E) loop
16197 Append (New_Copy_Tree (E), NL);
16198 E := Next (E);
16199 end loop;
16200
16201 return NL;
16202 end if;
16203 end New_Copy_List_Tree;
16204
16205 --------------------------------------------------
16206 -- New_Copy_Tree Auxiliary Data and Subprograms --
16207 --------------------------------------------------
16208
16209 use Atree.Unchecked_Access;
16210 use Atree_Private_Part;
16211
16212 -- Our approach here requires a two pass traversal of the tree. The
16213 -- first pass visits all nodes that eventually will be copied looking
16214 -- for defining Itypes. If any defining Itypes are found, then they are
16215 -- copied, and an entry is added to the replacement map. In the second
16216 -- phase, the tree is copied, using the replacement map to replace any
16217 -- Itype references within the copied tree.
16218
16219 -- The following hash tables are used if the Map supplied has more
16220 -- than hash threshold entries to speed up access to the map. If
16221 -- there are fewer entries, then the map is searched sequentially
16222 -- (because setting up a hash table for only a few entries takes
16223 -- more time than it saves.
16224
16225 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
16226 -- Hash function used for hash operations
16227
16228 -------------------
16229 -- New_Copy_Hash --
16230 -------------------
16231
16232 function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
16233 begin
16234 return Nat (E) mod (NCT_Header_Num'Last + 1);
16235 end New_Copy_Hash;
16236
16237 ---------------
16238 -- NCT_Assoc --
16239 ---------------
16240
16241 -- The hash table NCT_Assoc associates old entities in the table
16242 -- with their corresponding new entities (i.e. the pairs of entries
16243 -- presented in the original Map argument are Key-Element pairs).
16244
16245 package NCT_Assoc is new Simple_HTable (
16246 Header_Num => NCT_Header_Num,
16247 Element => Entity_Id,
16248 No_Element => Empty,
16249 Key => Entity_Id,
16250 Hash => New_Copy_Hash,
16251 Equal => Types."=");
16252
16253 ---------------------
16254 -- NCT_Itype_Assoc --
16255 ---------------------
16256
16257 -- The hash table NCT_Itype_Assoc contains entries only for those
16258 -- old nodes which have a non-empty Associated_Node_For_Itype set.
16259 -- The key is the associated node, and the element is the new node
16260 -- itself (NOT the associated node for the new node).
16261
16262 package NCT_Itype_Assoc is new Simple_HTable (
16263 Header_Num => NCT_Header_Num,
16264 Element => Entity_Id,
16265 No_Element => Empty,
16266 Key => Entity_Id,
16267 Hash => New_Copy_Hash,
16268 Equal => Types."=");
16269
16270 -------------------
16271 -- New_Copy_Tree --
16272 -------------------
16273
16274 function New_Copy_Tree
16275 (Source : Node_Id;
16276 Map : Elist_Id := No_Elist;
16277 New_Sloc : Source_Ptr := No_Location;
16278 New_Scope : Entity_Id := Empty) return Node_Id
16279 is
16280 Actual_Map : Elist_Id := Map;
16281 -- This is the actual map for the copy. It is initialized with the
16282 -- given elements, and then enlarged as required for Itypes that are
16283 -- copied during the first phase of the copy operation. The visit
16284 -- procedures add elements to this map as Itypes are encountered.
16285 -- The reason we cannot use Map directly, is that it may well be
16286 -- (and normally is) initialized to No_Elist, and if we have mapped
16287 -- entities, we have to reset it to point to a real Elist.
16288
16289 function Assoc (N : Node_Or_Entity_Id) return Node_Id;
16290 -- Called during second phase to map entities into their corresponding
16291 -- copies using Actual_Map. If the argument is not an entity, or is not
16292 -- in Actual_Map, then it is returned unchanged.
16293
16294 procedure Build_NCT_Hash_Tables;
16295 -- Builds hash tables (number of elements >= threshold value)
16296
16297 function Copy_Elist_With_Replacement
16298 (Old_Elist : Elist_Id) return Elist_Id;
16299 -- Called during second phase to copy element list doing replacements
16300
16301 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
16302 -- Called during the second phase to process a copied Itype. The actual
16303 -- copy happened during the first phase (so that we could make the entry
16304 -- in the mapping), but we still have to deal with the descendants of
16305 -- the copied Itype and copy them where necessary.
16306
16307 function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
16308 -- Called during second phase to copy list doing replacements
16309
16310 function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
16311 -- Called during second phase to copy node doing replacements
16312
16313 procedure Visit_Elist (E : Elist_Id);
16314 -- Called during first phase to visit all elements of an Elist
16315
16316 procedure Visit_Field (F : Union_Id; N : Node_Id);
16317 -- Visit a single field, recursing to call Visit_Node or Visit_List
16318 -- if the field is a syntactic descendant of the current node (i.e.
16319 -- its parent is Node N).
16320
16321 procedure Visit_Itype (Old_Itype : Entity_Id);
16322 -- Called during first phase to visit subsidiary fields of a defining
16323 -- Itype, and also create a copy and make an entry in the replacement
16324 -- map for the new copy.
16325
16326 procedure Visit_List (L : List_Id);
16327 -- Called during first phase to visit all elements of a List
16328
16329 procedure Visit_Node (N : Node_Or_Entity_Id);
16330 -- Called during first phase to visit a node and all its subtrees
16331
16332 -----------
16333 -- Assoc --
16334 -----------
16335
16336 function Assoc (N : Node_Or_Entity_Id) return Node_Id is
16337 E : Elmt_Id;
16338 Ent : Entity_Id;
16339
16340 begin
16341 if not Has_Extension (N) or else No (Actual_Map) then
16342 return N;
16343
16344 elsif NCT_Hash_Tables_Used then
16345 Ent := NCT_Assoc.Get (Entity_Id (N));
16346
16347 if Present (Ent) then
16348 return Ent;
16349 else
16350 return N;
16351 end if;
16352
16353 -- No hash table used, do serial search
16354
16355 else
16356 E := First_Elmt (Actual_Map);
16357 while Present (E) loop
16358 if Node (E) = N then
16359 return Node (Next_Elmt (E));
16360 else
16361 E := Next_Elmt (Next_Elmt (E));
16362 end if;
16363 end loop;
16364 end if;
16365
16366 return N;
16367 end Assoc;
16368
16369 ---------------------------
16370 -- Build_NCT_Hash_Tables --
16371 ---------------------------
16372
16373 procedure Build_NCT_Hash_Tables is
16374 Elmt : Elmt_Id;
16375 Ent : Entity_Id;
16376 begin
16377 if NCT_Hash_Table_Setup then
16378 NCT_Assoc.Reset;
16379 NCT_Itype_Assoc.Reset;
16380 end if;
16381
16382 Elmt := First_Elmt (Actual_Map);
16383 while Present (Elmt) loop
16384 Ent := Node (Elmt);
16385
16386 -- Get new entity, and associate old and new
16387
16388 Next_Elmt (Elmt);
16389 NCT_Assoc.Set (Ent, Node (Elmt));
16390
16391 if Is_Type (Ent) then
16392 declare
16393 Anode : constant Entity_Id :=
16394 Associated_Node_For_Itype (Ent);
16395
16396 begin
16397 if Present (Anode) then
16398
16399 -- Enter a link between the associated node of the
16400 -- old Itype and the new Itype, for updating later
16401 -- when node is copied.
16402
16403 NCT_Itype_Assoc.Set (Anode, Node (Elmt));
16404 end if;
16405 end;
16406 end if;
16407
16408 Next_Elmt (Elmt);
16409 end loop;
16410
16411 NCT_Hash_Tables_Used := True;
16412 NCT_Hash_Table_Setup := True;
16413 end Build_NCT_Hash_Tables;
16414
16415 ---------------------------------
16416 -- Copy_Elist_With_Replacement --
16417 ---------------------------------
16418
16419 function Copy_Elist_With_Replacement
16420 (Old_Elist : Elist_Id) return Elist_Id
16421 is
16422 M : Elmt_Id;
16423 New_Elist : Elist_Id;
16424
16425 begin
16426 if No (Old_Elist) then
16427 return No_Elist;
16428
16429 else
16430 New_Elist := New_Elmt_List;
16431
16432 M := First_Elmt (Old_Elist);
16433 while Present (M) loop
16434 Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
16435 Next_Elmt (M);
16436 end loop;
16437 end if;
16438
16439 return New_Elist;
16440 end Copy_Elist_With_Replacement;
16441
16442 ---------------------------------
16443 -- Copy_Itype_With_Replacement --
16444 ---------------------------------
16445
16446 -- This routine exactly parallels its phase one analog Visit_Itype,
16447
16448 procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
16449 begin
16450 -- Translate Next_Entity, Scope, and Etype fields, in case they
16451 -- reference entities that have been mapped into copies.
16452
16453 Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
16454 Set_Etype (New_Itype, Assoc (Etype (New_Itype)));
16455
16456 if Present (New_Scope) then
16457 Set_Scope (New_Itype, New_Scope);
16458 else
16459 Set_Scope (New_Itype, Assoc (Scope (New_Itype)));
16460 end if;
16461
16462 -- Copy referenced fields
16463
16464 if Is_Discrete_Type (New_Itype) then
16465 Set_Scalar_Range (New_Itype,
16466 Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
16467
16468 elsif Has_Discriminants (Base_Type (New_Itype)) then
16469 Set_Discriminant_Constraint (New_Itype,
16470 Copy_Elist_With_Replacement
16471 (Discriminant_Constraint (New_Itype)));
16472
16473 elsif Is_Array_Type (New_Itype) then
16474 if Present (First_Index (New_Itype)) then
16475 Set_First_Index (New_Itype,
16476 First (Copy_List_With_Replacement
16477 (List_Containing (First_Index (New_Itype)))));
16478 end if;
16479
16480 if Is_Packed (New_Itype) then
16481 Set_Packed_Array_Impl_Type (New_Itype,
16482 Copy_Node_With_Replacement
16483 (Packed_Array_Impl_Type (New_Itype)));
16484 end if;
16485 end if;
16486 end Copy_Itype_With_Replacement;
16487
16488 --------------------------------
16489 -- Copy_List_With_Replacement --
16490 --------------------------------
16491
16492 function Copy_List_With_Replacement
16493 (Old_List : List_Id) return List_Id
16494 is
16495 New_List : List_Id;
16496 E : Node_Id;
16497
16498 begin
16499 if Old_List = No_List then
16500 return No_List;
16501
16502 else
16503 New_List := Empty_List;
16504
16505 E := First (Old_List);
16506 while Present (E) loop
16507 Append (Copy_Node_With_Replacement (E), New_List);
16508 Next (E);
16509 end loop;
16510
16511 return New_List;
16512 end if;
16513 end Copy_List_With_Replacement;
16514
16515 --------------------------------
16516 -- Copy_Node_With_Replacement --
16517 --------------------------------
16518
16519 function Copy_Node_With_Replacement
16520 (Old_Node : Node_Id) return Node_Id
16521 is
16522 New_Node : Node_Id;
16523
16524 procedure Adjust_Named_Associations
16525 (Old_Node : Node_Id;
16526 New_Node : Node_Id);
16527 -- If a call node has named associations, these are chained through
16528 -- the First_Named_Actual, Next_Named_Actual links. These must be
16529 -- propagated separately to the new parameter list, because these
16530 -- are not syntactic fields.
16531
16532 function Copy_Field_With_Replacement
16533 (Field : Union_Id) return Union_Id;
16534 -- Given Field, which is a field of Old_Node, return a copy of it
16535 -- if it is a syntactic field (i.e. its parent is Node), setting
16536 -- the parent of the copy to poit to New_Node. Otherwise returns
16537 -- the field (possibly mapped if it is an entity).
16538
16539 -------------------------------
16540 -- Adjust_Named_Associations --
16541 -------------------------------
16542
16543 procedure Adjust_Named_Associations
16544 (Old_Node : Node_Id;
16545 New_Node : Node_Id)
16546 is
16547 Old_E : Node_Id;
16548 New_E : Node_Id;
16549
16550 Old_Next : Node_Id;
16551 New_Next : Node_Id;
16552
16553 begin
16554 Old_E := First (Parameter_Associations (Old_Node));
16555 New_E := First (Parameter_Associations (New_Node));
16556 while Present (Old_E) loop
16557 if Nkind (Old_E) = N_Parameter_Association
16558 and then Present (Next_Named_Actual (Old_E))
16559 then
16560 if First_Named_Actual (Old_Node)
16561 = Explicit_Actual_Parameter (Old_E)
16562 then
16563 Set_First_Named_Actual
16564 (New_Node, Explicit_Actual_Parameter (New_E));
16565 end if;
16566
16567 -- Now scan parameter list from the beginning,to locate
16568 -- next named actual, which can be out of order.
16569
16570 Old_Next := First (Parameter_Associations (Old_Node));
16571 New_Next := First (Parameter_Associations (New_Node));
16572
16573 while Nkind (Old_Next) /= N_Parameter_Association
16574 or else Explicit_Actual_Parameter (Old_Next) /=
16575 Next_Named_Actual (Old_E)
16576 loop
16577 Next (Old_Next);
16578 Next (New_Next);
16579 end loop;
16580
16581 Set_Next_Named_Actual
16582 (New_E, Explicit_Actual_Parameter (New_Next));
16583 end if;
16584
16585 Next (Old_E);
16586 Next (New_E);
16587 end loop;
16588 end Adjust_Named_Associations;
16589
16590 ---------------------------------
16591 -- Copy_Field_With_Replacement --
16592 ---------------------------------
16593
16594 function Copy_Field_With_Replacement
16595 (Field : Union_Id) return Union_Id
16596 is
16597 begin
16598 if Field = Union_Id (Empty) then
16599 return Field;
16600
16601 elsif Field in Node_Range then
16602 declare
16603 Old_N : constant Node_Id := Node_Id (Field);
16604 New_N : Node_Id;
16605
16606 begin
16607 -- If syntactic field, as indicated by the parent pointer
16608 -- being set, then copy the referenced node recursively.
16609
16610 if Parent (Old_N) = Old_Node then
16611 New_N := Copy_Node_With_Replacement (Old_N);
16612
16613 if New_N /= Old_N then
16614 Set_Parent (New_N, New_Node);
16615 end if;
16616
16617 -- For semantic fields, update possible entity reference
16618 -- from the replacement map.
16619
16620 else
16621 New_N := Assoc (Old_N);
16622 end if;
16623
16624 return Union_Id (New_N);
16625 end;
16626
16627 elsif Field in List_Range then
16628 declare
16629 Old_L : constant List_Id := List_Id (Field);
16630 New_L : List_Id;
16631
16632 begin
16633 -- If syntactic field, as indicated by the parent pointer,
16634 -- then recursively copy the entire referenced list.
16635
16636 if Parent (Old_L) = Old_Node then
16637 New_L := Copy_List_With_Replacement (Old_L);
16638 Set_Parent (New_L, New_Node);
16639
16640 -- For semantic list, just returned unchanged
16641
16642 else
16643 New_L := Old_L;
16644 end if;
16645
16646 return Union_Id (New_L);
16647 end;
16648
16649 -- Anything other than a list or a node is returned unchanged
16650
16651 else
16652 return Field;
16653 end if;
16654 end Copy_Field_With_Replacement;
16655
16656 -- Start of processing for Copy_Node_With_Replacement
16657
16658 begin
16659 if Old_Node <= Empty_Or_Error then
16660 return Old_Node;
16661
16662 elsif Has_Extension (Old_Node) then
16663 return Assoc (Old_Node);
16664
16665 else
16666 New_Node := New_Copy (Old_Node);
16667
16668 -- If the node we are copying is the associated node of a
16669 -- previously copied Itype, then adjust the associated node
16670 -- of the copy of that Itype accordingly.
16671
16672 if Present (Actual_Map) then
16673 declare
16674 E : Elmt_Id;
16675 Ent : Entity_Id;
16676
16677 begin
16678 -- Case of hash table used
16679
16680 if NCT_Hash_Tables_Used then
16681 Ent := NCT_Itype_Assoc.Get (Old_Node);
16682
16683 if Present (Ent) then
16684 Set_Associated_Node_For_Itype (Ent, New_Node);
16685 end if;
16686
16687 -- Case of no hash table used
16688
16689 else
16690 E := First_Elmt (Actual_Map);
16691 while Present (E) loop
16692 if Is_Itype (Node (E))
16693 and then
16694 Old_Node = Associated_Node_For_Itype (Node (E))
16695 then
16696 Set_Associated_Node_For_Itype
16697 (Node (Next_Elmt (E)), New_Node);
16698 end if;
16699
16700 E := Next_Elmt (Next_Elmt (E));
16701 end loop;
16702 end if;
16703 end;
16704 end if;
16705
16706 -- Recursively copy descendants
16707
16708 Set_Field1
16709 (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
16710 Set_Field2
16711 (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
16712 Set_Field3
16713 (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
16714 Set_Field4
16715 (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
16716 Set_Field5
16717 (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
16718
16719 -- Adjust Sloc of new node if necessary
16720
16721 if New_Sloc /= No_Location then
16722 Set_Sloc (New_Node, New_Sloc);
16723
16724 -- If we adjust the Sloc, then we are essentially making a
16725 -- completely new node, so the Comes_From_Source flag should
16726 -- be reset to the proper default value.
16727
16728 Set_Comes_From_Source
16729 (New_Node, Default_Node.Comes_From_Source);
16730 end if;
16731
16732 -- If the node is a call and has named associations, set the
16733 -- corresponding links in the copy.
16734
16735 if Nkind_In (Old_Node, N_Entry_Call_Statement,
16736 N_Function_Call,
16737 N_Procedure_Call_Statement)
16738 and then Present (First_Named_Actual (Old_Node))
16739 then
16740 Adjust_Named_Associations (Old_Node, New_Node);
16741 end if;
16742
16743 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
16744 -- The replacement mechanism applies to entities, and is not used
16745 -- here. Eventually we may need a more general graph-copying
16746 -- routine. For now, do a sequential search to find desired node.
16747
16748 if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
16749 and then Present (First_Real_Statement (Old_Node))
16750 then
16751 declare
16752 Old_F : constant Node_Id := First_Real_Statement (Old_Node);
16753 N1, N2 : Node_Id;
16754
16755 begin
16756 N1 := First (Statements (Old_Node));
16757 N2 := First (Statements (New_Node));
16758
16759 while N1 /= Old_F loop
16760 Next (N1);
16761 Next (N2);
16762 end loop;
16763
16764 Set_First_Real_Statement (New_Node, N2);
16765 end;
16766 end if;
16767 end if;
16768
16769 -- All done, return copied node
16770
16771 return New_Node;
16772 end Copy_Node_With_Replacement;
16773
16774 -----------------
16775 -- Visit_Elist --
16776 -----------------
16777
16778 procedure Visit_Elist (E : Elist_Id) is
16779 Elmt : Elmt_Id;
16780 begin
16781 if Present (E) then
16782 Elmt := First_Elmt (E);
16783
16784 while Elmt /= No_Elmt loop
16785 Visit_Node (Node (Elmt));
16786 Next_Elmt (Elmt);
16787 end loop;
16788 end if;
16789 end Visit_Elist;
16790
16791 -----------------
16792 -- Visit_Field --
16793 -----------------
16794
16795 procedure Visit_Field (F : Union_Id; N : Node_Id) is
16796 begin
16797 if F = Union_Id (Empty) then
16798 return;
16799
16800 elsif F in Node_Range then
16801
16802 -- Copy node if it is syntactic, i.e. its parent pointer is
16803 -- set to point to the field that referenced it (certain
16804 -- Itypes will also meet this criterion, which is fine, since
16805 -- these are clearly Itypes that do need to be copied, since
16806 -- we are copying their parent.)
16807
16808 if Parent (Node_Id (F)) = N then
16809 Visit_Node (Node_Id (F));
16810 return;
16811
16812 -- Another case, if we are pointing to an Itype, then we want
16813 -- to copy it if its associated node is somewhere in the tree
16814 -- being copied.
16815
16816 -- Note: the exclusion of self-referential copies is just an
16817 -- optimization, since the search of the already copied list
16818 -- would catch it, but it is a common case (Etype pointing
16819 -- to itself for an Itype that is a base type).
16820
16821 elsif Has_Extension (Node_Id (F))
16822 and then Is_Itype (Entity_Id (F))
16823 and then Node_Id (F) /= N
16824 then
16825 declare
16826 P : Node_Id;
16827
16828 begin
16829 P := Associated_Node_For_Itype (Node_Id (F));
16830 while Present (P) loop
16831 if P = Source then
16832 Visit_Node (Node_Id (F));
16833 return;
16834 else
16835 P := Parent (P);
16836 end if;
16837 end loop;
16838
16839 -- An Itype whose parent is not being copied definitely
16840 -- should NOT be copied, since it does not belong in any
16841 -- sense to the copied subtree.
16842
16843 return;
16844 end;
16845 end if;
16846
16847 elsif F in List_Range and then Parent (List_Id (F)) = N then
16848 Visit_List (List_Id (F));
16849 return;
16850 end if;
16851 end Visit_Field;
16852
16853 -----------------
16854 -- Visit_Itype --
16855 -----------------
16856
16857 procedure Visit_Itype (Old_Itype : Entity_Id) is
16858 New_Itype : Entity_Id;
16859 E : Elmt_Id;
16860 Ent : Entity_Id;
16861
16862 begin
16863 -- Itypes that describe the designated type of access to subprograms
16864 -- have the structure of subprogram declarations, with signatures,
16865 -- etc. Either we duplicate the signatures completely, or choose to
16866 -- share such itypes, which is fine because their elaboration will
16867 -- have no side effects.
16868
16869 if Ekind (Old_Itype) = E_Subprogram_Type then
16870 return;
16871 end if;
16872
16873 New_Itype := New_Copy (Old_Itype);
16874
16875 -- The new Itype has all the attributes of the old one, and
16876 -- we just copy the contents of the entity. However, the back-end
16877 -- needs different names for debugging purposes, so we create a
16878 -- new internal name for it in all cases.
16879
16880 Set_Chars (New_Itype, New_Internal_Name ('T'));
16881
16882 -- If our associated node is an entity that has already been copied,
16883 -- then set the associated node of the copy to point to the right
16884 -- copy. If we have copied an Itype that is itself the associated
16885 -- node of some previously copied Itype, then we set the right
16886 -- pointer in the other direction.
16887
16888 if Present (Actual_Map) then
16889
16890 -- Case of hash tables used
16891
16892 if NCT_Hash_Tables_Used then
16893
16894 Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
16895
16896 if Present (Ent) then
16897 Set_Associated_Node_For_Itype (New_Itype, Ent);
16898 end if;
16899
16900 Ent := NCT_Itype_Assoc.Get (Old_Itype);
16901 if Present (Ent) then
16902 Set_Associated_Node_For_Itype (Ent, New_Itype);
16903
16904 -- If the hash table has no association for this Itype and
16905 -- its associated node, enter one now.
16906
16907 else
16908 NCT_Itype_Assoc.Set
16909 (Associated_Node_For_Itype (Old_Itype), New_Itype);
16910 end if;
16911
16912 -- Case of hash tables not used
16913
16914 else
16915 E := First_Elmt (Actual_Map);
16916 while Present (E) loop
16917 if Associated_Node_For_Itype (Old_Itype) = Node (E) then
16918 Set_Associated_Node_For_Itype
16919 (New_Itype, Node (Next_Elmt (E)));
16920 end if;
16921
16922 if Is_Type (Node (E))
16923 and then Old_Itype = Associated_Node_For_Itype (Node (E))
16924 then
16925 Set_Associated_Node_For_Itype
16926 (Node (Next_Elmt (E)), New_Itype);
16927 end if;
16928
16929 E := Next_Elmt (Next_Elmt (E));
16930 end loop;
16931 end if;
16932 end if;
16933
16934 if Present (Freeze_Node (New_Itype)) then
16935 Set_Is_Frozen (New_Itype, False);
16936 Set_Freeze_Node (New_Itype, Empty);
16937 end if;
16938
16939 -- Add new association to map
16940
16941 if No (Actual_Map) then
16942 Actual_Map := New_Elmt_List;
16943 end if;
16944
16945 Append_Elmt (Old_Itype, Actual_Map);
16946 Append_Elmt (New_Itype, Actual_Map);
16947
16948 if NCT_Hash_Tables_Used then
16949 NCT_Assoc.Set (Old_Itype, New_Itype);
16950
16951 else
16952 NCT_Table_Entries := NCT_Table_Entries + 1;
16953
16954 if NCT_Table_Entries > NCT_Hash_Threshold then
16955 Build_NCT_Hash_Tables;
16956 end if;
16957 end if;
16958
16959 -- If a record subtype is simply copied, the entity list will be
16960 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
16961
16962 if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
16963 Set_Cloned_Subtype (New_Itype, Old_Itype);
16964 end if;
16965
16966 -- Visit descendants that eventually get copied
16967
16968 Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
16969
16970 if Is_Discrete_Type (Old_Itype) then
16971 Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
16972
16973 elsif Has_Discriminants (Base_Type (Old_Itype)) then
16974 -- ??? This should involve call to Visit_Field
16975 Visit_Elist (Discriminant_Constraint (Old_Itype));
16976
16977 elsif Is_Array_Type (Old_Itype) then
16978 if Present (First_Index (Old_Itype)) then
16979 Visit_Field (Union_Id (List_Containing
16980 (First_Index (Old_Itype))),
16981 Old_Itype);
16982 end if;
16983
16984 if Is_Packed (Old_Itype) then
16985 Visit_Field (Union_Id (Packed_Array_Impl_Type (Old_Itype)),
16986 Old_Itype);
16987 end if;
16988 end if;
16989 end Visit_Itype;
16990
16991 ----------------
16992 -- Visit_List --
16993 ----------------
16994
16995 procedure Visit_List (L : List_Id) is
16996 N : Node_Id;
16997 begin
16998 if L /= No_List then
16999 N := First (L);
17000
17001 while Present (N) loop
17002 Visit_Node (N);
17003 Next (N);
17004 end loop;
17005 end if;
17006 end Visit_List;
17007
17008 ----------------
17009 -- Visit_Node --
17010 ----------------
17011
17012 procedure Visit_Node (N : Node_Or_Entity_Id) is
17013
17014 -- Start of processing for Visit_Node
17015
17016 begin
17017 -- Handle case of an Itype, which must be copied
17018
17019 if Has_Extension (N) and then Is_Itype (N) then
17020
17021 -- Nothing to do if already in the list. This can happen with an
17022 -- Itype entity that appears more than once in the tree.
17023 -- Note that we do not want to visit descendants in this case.
17024
17025 -- Test for already in list when hash table is used
17026
17027 if NCT_Hash_Tables_Used then
17028 if Present (NCT_Assoc.Get (Entity_Id (N))) then
17029 return;
17030 end if;
17031
17032 -- Test for already in list when hash table not used
17033
17034 else
17035 declare
17036 E : Elmt_Id;
17037 begin
17038 if Present (Actual_Map) then
17039 E := First_Elmt (Actual_Map);
17040 while Present (E) loop
17041 if Node (E) = N then
17042 return;
17043 else
17044 E := Next_Elmt (Next_Elmt (E));
17045 end if;
17046 end loop;
17047 end if;
17048 end;
17049 end if;
17050
17051 Visit_Itype (N);
17052 end if;
17053
17054 -- Visit descendants
17055
17056 Visit_Field (Field1 (N), N);
17057 Visit_Field (Field2 (N), N);
17058 Visit_Field (Field3 (N), N);
17059 Visit_Field (Field4 (N), N);
17060 Visit_Field (Field5 (N), N);
17061 end Visit_Node;
17062
17063 -- Start of processing for New_Copy_Tree
17064
17065 begin
17066 Actual_Map := Map;
17067
17068 -- See if we should use hash table
17069
17070 if No (Actual_Map) then
17071 NCT_Hash_Tables_Used := False;
17072
17073 else
17074 declare
17075 Elmt : Elmt_Id;
17076
17077 begin
17078 NCT_Table_Entries := 0;
17079
17080 Elmt := First_Elmt (Actual_Map);
17081 while Present (Elmt) loop
17082 NCT_Table_Entries := NCT_Table_Entries + 1;
17083 Next_Elmt (Elmt);
17084 Next_Elmt (Elmt);
17085 end loop;
17086
17087 if NCT_Table_Entries > NCT_Hash_Threshold then
17088 Build_NCT_Hash_Tables;
17089 else
17090 NCT_Hash_Tables_Used := False;
17091 end if;
17092 end;
17093 end if;
17094
17095 -- Hash table set up if required, now start phase one by visiting
17096 -- top node (we will recursively visit the descendants).
17097
17098 Visit_Node (Source);
17099
17100 -- Now the second phase of the copy can start. First we process
17101 -- all the mapped entities, copying their descendants.
17102
17103 if Present (Actual_Map) then
17104 declare
17105 Elmt : Elmt_Id;
17106 New_Itype : Entity_Id;
17107 begin
17108 Elmt := First_Elmt (Actual_Map);
17109 while Present (Elmt) loop
17110 Next_Elmt (Elmt);
17111 New_Itype := Node (Elmt);
17112
17113 if Is_Itype (New_Itype) then
17114 Copy_Itype_With_Replacement (New_Itype);
17115 end if;
17116 Next_Elmt (Elmt);
17117 end loop;
17118 end;
17119 end if;
17120
17121 -- Now we can copy the actual tree
17122
17123 return Copy_Node_With_Replacement (Source);
17124 end New_Copy_Tree;
17125
17126 -------------------------
17127 -- New_External_Entity --
17128 -------------------------
17129
17130 function New_External_Entity
17131 (Kind : Entity_Kind;
17132 Scope_Id : Entity_Id;
17133 Sloc_Value : Source_Ptr;
17134 Related_Id : Entity_Id;
17135 Suffix : Character;
17136 Suffix_Index : Nat := 0;
17137 Prefix : Character := ' ') return Entity_Id
17138 is
17139 N : constant Entity_Id :=
17140 Make_Defining_Identifier (Sloc_Value,
17141 New_External_Name
17142 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
17143
17144 begin
17145 Set_Ekind (N, Kind);
17146 Set_Is_Internal (N, True);
17147 Append_Entity (N, Scope_Id);
17148 Set_Public_Status (N);
17149
17150 if Kind in Type_Kind then
17151 Init_Size_Align (N);
17152 end if;
17153
17154 return N;
17155 end New_External_Entity;
17156
17157 -------------------------
17158 -- New_Internal_Entity --
17159 -------------------------
17160
17161 function New_Internal_Entity
17162 (Kind : Entity_Kind;
17163 Scope_Id : Entity_Id;
17164 Sloc_Value : Source_Ptr;
17165 Id_Char : Character) return Entity_Id
17166 is
17167 N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
17168
17169 begin
17170 Set_Ekind (N, Kind);
17171 Set_Is_Internal (N, True);
17172 Append_Entity (N, Scope_Id);
17173
17174 if Kind in Type_Kind then
17175 Init_Size_Align (N);
17176 end if;
17177
17178 return N;
17179 end New_Internal_Entity;
17180
17181 -----------------
17182 -- Next_Actual --
17183 -----------------
17184
17185 function Next_Actual (Actual_Id : Node_Id) return Node_Id is
17186 N : Node_Id;
17187
17188 begin
17189 -- If we are pointing at a positional parameter, it is a member of a
17190 -- node list (the list of parameters), and the next parameter is the
17191 -- next node on the list, unless we hit a parameter association, then
17192 -- we shift to using the chain whose head is the First_Named_Actual in
17193 -- the parent, and then is threaded using the Next_Named_Actual of the
17194 -- Parameter_Association. All this fiddling is because the original node
17195 -- list is in the textual call order, and what we need is the
17196 -- declaration order.
17197
17198 if Is_List_Member (Actual_Id) then
17199 N := Next (Actual_Id);
17200
17201 if Nkind (N) = N_Parameter_Association then
17202 return First_Named_Actual (Parent (Actual_Id));
17203 else
17204 return N;
17205 end if;
17206
17207 else
17208 return Next_Named_Actual (Parent (Actual_Id));
17209 end if;
17210 end Next_Actual;
17211
17212 procedure Next_Actual (Actual_Id : in out Node_Id) is
17213 begin
17214 Actual_Id := Next_Actual (Actual_Id);
17215 end Next_Actual;
17216
17217 -----------------------
17218 -- Normalize_Actuals --
17219 -----------------------
17220
17221 -- Chain actuals according to formals of subprogram. If there are no named
17222 -- associations, the chain is simply the list of Parameter Associations,
17223 -- since the order is the same as the declaration order. If there are named
17224 -- associations, then the First_Named_Actual field in the N_Function_Call
17225 -- or N_Procedure_Call_Statement node points to the Parameter_Association
17226 -- node for the parameter that comes first in declaration order. The
17227 -- remaining named parameters are then chained in declaration order using
17228 -- Next_Named_Actual.
17229
17230 -- This routine also verifies that the number of actuals is compatible with
17231 -- the number and default values of formals, but performs no type checking
17232 -- (type checking is done by the caller).
17233
17234 -- If the matching succeeds, Success is set to True and the caller proceeds
17235 -- with type-checking. If the match is unsuccessful, then Success is set to
17236 -- False, and the caller attempts a different interpretation, if there is
17237 -- one.
17238
17239 -- If the flag Report is on, the call is not overloaded, and a failure to
17240 -- match can be reported here, rather than in the caller.
17241
17242 procedure Normalize_Actuals
17243 (N : Node_Id;
17244 S : Entity_Id;
17245 Report : Boolean;
17246 Success : out Boolean)
17247 is
17248 Actuals : constant List_Id := Parameter_Associations (N);
17249 Actual : Node_Id := Empty;
17250 Formal : Entity_Id;
17251 Last : Node_Id := Empty;
17252 First_Named : Node_Id := Empty;
17253 Found : Boolean;
17254
17255 Formals_To_Match : Integer := 0;
17256 Actuals_To_Match : Integer := 0;
17257
17258 procedure Chain (A : Node_Id);
17259 -- Add named actual at the proper place in the list, using the
17260 -- Next_Named_Actual link.
17261
17262 function Reporting return Boolean;
17263 -- Determines if an error is to be reported. To report an error, we
17264 -- need Report to be True, and also we do not report errors caused
17265 -- by calls to init procs that occur within other init procs. Such
17266 -- errors must always be cascaded errors, since if all the types are
17267 -- declared correctly, the compiler will certainly build decent calls.
17268
17269 -----------
17270 -- Chain --
17271 -----------
17272
17273 procedure Chain (A : Node_Id) is
17274 begin
17275 if No (Last) then
17276
17277 -- Call node points to first actual in list
17278
17279 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
17280
17281 else
17282 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
17283 end if;
17284
17285 Last := A;
17286 Set_Next_Named_Actual (Last, Empty);
17287 end Chain;
17288
17289 ---------------
17290 -- Reporting --
17291 ---------------
17292
17293 function Reporting return Boolean is
17294 begin
17295 if not Report then
17296 return False;
17297
17298 elsif not Within_Init_Proc then
17299 return True;
17300
17301 elsif Is_Init_Proc (Entity (Name (N))) then
17302 return False;
17303
17304 else
17305 return True;
17306 end if;
17307 end Reporting;
17308
17309 -- Start of processing for Normalize_Actuals
17310
17311 begin
17312 if Is_Access_Type (S) then
17313
17314 -- The name in the call is a function call that returns an access
17315 -- to subprogram. The designated type has the list of formals.
17316
17317 Formal := First_Formal (Designated_Type (S));
17318 else
17319 Formal := First_Formal (S);
17320 end if;
17321
17322 while Present (Formal) loop
17323 Formals_To_Match := Formals_To_Match + 1;
17324 Next_Formal (Formal);
17325 end loop;
17326
17327 -- Find if there is a named association, and verify that no positional
17328 -- associations appear after named ones.
17329
17330 if Present (Actuals) then
17331 Actual := First (Actuals);
17332 end if;
17333
17334 while Present (Actual)
17335 and then Nkind (Actual) /= N_Parameter_Association
17336 loop
17337 Actuals_To_Match := Actuals_To_Match + 1;
17338 Next (Actual);
17339 end loop;
17340
17341 if No (Actual) and Actuals_To_Match = Formals_To_Match then
17342
17343 -- Most common case: positional notation, no defaults
17344
17345 Success := True;
17346 return;
17347
17348 elsif Actuals_To_Match > Formals_To_Match then
17349
17350 -- Too many actuals: will not work
17351
17352 if Reporting then
17353 if Is_Entity_Name (Name (N)) then
17354 Error_Msg_N ("too many arguments in call to&", Name (N));
17355 else
17356 Error_Msg_N ("too many arguments in call", N);
17357 end if;
17358 end if;
17359
17360 Success := False;
17361 return;
17362 end if;
17363
17364 First_Named := Actual;
17365
17366 while Present (Actual) loop
17367 if Nkind (Actual) /= N_Parameter_Association then
17368 Error_Msg_N
17369 ("positional parameters not allowed after named ones", Actual);
17370 Success := False;
17371 return;
17372
17373 else
17374 Actuals_To_Match := Actuals_To_Match + 1;
17375 end if;
17376
17377 Next (Actual);
17378 end loop;
17379
17380 if Present (Actuals) then
17381 Actual := First (Actuals);
17382 end if;
17383
17384 Formal := First_Formal (S);
17385 while Present (Formal) loop
17386
17387 -- Match the formals in order. If the corresponding actual is
17388 -- positional, nothing to do. Else scan the list of named actuals
17389 -- to find the one with the right name.
17390
17391 if Present (Actual)
17392 and then Nkind (Actual) /= N_Parameter_Association
17393 then
17394 Next (Actual);
17395 Actuals_To_Match := Actuals_To_Match - 1;
17396 Formals_To_Match := Formals_To_Match - 1;
17397
17398 else
17399 -- For named parameters, search the list of actuals to find
17400 -- one that matches the next formal name.
17401
17402 Actual := First_Named;
17403 Found := False;
17404 while Present (Actual) loop
17405 if Chars (Selector_Name (Actual)) = Chars (Formal) then
17406 Found := True;
17407 Chain (Actual);
17408 Actuals_To_Match := Actuals_To_Match - 1;
17409 Formals_To_Match := Formals_To_Match - 1;
17410 exit;
17411 end if;
17412
17413 Next (Actual);
17414 end loop;
17415
17416 if not Found then
17417 if Ekind (Formal) /= E_In_Parameter
17418 or else No (Default_Value (Formal))
17419 then
17420 if Reporting then
17421 if (Comes_From_Source (S)
17422 or else Sloc (S) = Standard_Location)
17423 and then Is_Overloadable (S)
17424 then
17425 if No (Actuals)
17426 and then
17427 Nkind_In (Parent (N), N_Procedure_Call_Statement,
17428 N_Function_Call,
17429 N_Parameter_Association)
17430 and then Ekind (S) /= E_Function
17431 then
17432 Set_Etype (N, Etype (S));
17433
17434 else
17435 Error_Msg_Name_1 := Chars (S);
17436 Error_Msg_Sloc := Sloc (S);
17437 Error_Msg_NE
17438 ("missing argument for parameter & "
17439 & "in call to % declared #", N, Formal);
17440 end if;
17441
17442 elsif Is_Overloadable (S) then
17443 Error_Msg_Name_1 := Chars (S);
17444
17445 -- Point to type derivation that generated the
17446 -- operation.
17447
17448 Error_Msg_Sloc := Sloc (Parent (S));
17449
17450 Error_Msg_NE
17451 ("missing argument for parameter & "
17452 & "in call to % (inherited) #", N, Formal);
17453
17454 else
17455 Error_Msg_NE
17456 ("missing argument for parameter &", N, Formal);
17457 end if;
17458 end if;
17459
17460 Success := False;
17461 return;
17462
17463 else
17464 Formals_To_Match := Formals_To_Match - 1;
17465 end if;
17466 end if;
17467 end if;
17468
17469 Next_Formal (Formal);
17470 end loop;
17471
17472 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
17473 Success := True;
17474 return;
17475
17476 else
17477 if Reporting then
17478
17479 -- Find some superfluous named actual that did not get
17480 -- attached to the list of associations.
17481
17482 Actual := First (Actuals);
17483 while Present (Actual) loop
17484 if Nkind (Actual) = N_Parameter_Association
17485 and then Actual /= Last
17486 and then No (Next_Named_Actual (Actual))
17487 then
17488 -- A validity check may introduce a copy of a call that
17489 -- includes an extra actual (for example for an unrelated
17490 -- accessibility check). Check that the extra actual matches
17491 -- some extra formal, which must exist already because
17492 -- subprogram must be frozen at this point.
17493
17494 if Present (Extra_Formals (S))
17495 and then not Comes_From_Source (Actual)
17496 and then Nkind (Actual) = N_Parameter_Association
17497 and then Chars (Extra_Formals (S)) =
17498 Chars (Selector_Name (Actual))
17499 then
17500 null;
17501 else
17502 Error_Msg_N
17503 ("unmatched actual & in call", Selector_Name (Actual));
17504 exit;
17505 end if;
17506 end if;
17507
17508 Next (Actual);
17509 end loop;
17510 end if;
17511
17512 Success := False;
17513 return;
17514 end if;
17515 end Normalize_Actuals;
17516
17517 --------------------------------
17518 -- Note_Possible_Modification --
17519 --------------------------------
17520
17521 procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
17522 Modification_Comes_From_Source : constant Boolean :=
17523 Comes_From_Source (Parent (N));
17524
17525 Ent : Entity_Id;
17526 Exp : Node_Id;
17527
17528 begin
17529 -- Loop to find referenced entity, if there is one
17530
17531 Exp := N;
17532 loop
17533 Ent := Empty;
17534
17535 if Is_Entity_Name (Exp) then
17536 Ent := Entity (Exp);
17537
17538 -- If the entity is missing, it is an undeclared identifier,
17539 -- and there is nothing to annotate.
17540
17541 if No (Ent) then
17542 return;
17543 end if;
17544
17545 elsif Nkind (Exp) = N_Explicit_Dereference then
17546 declare
17547 P : constant Node_Id := Prefix (Exp);
17548
17549 begin
17550 -- In formal verification mode, keep track of all reads and
17551 -- writes through explicit dereferences.
17552
17553 if GNATprove_Mode then
17554 SPARK_Specific.Generate_Dereference (N, 'm');
17555 end if;
17556
17557 if Nkind (P) = N_Selected_Component
17558 and then Present (Entry_Formal (Entity (Selector_Name (P))))
17559 then
17560 -- Case of a reference to an entry formal
17561
17562 Ent := Entry_Formal (Entity (Selector_Name (P)));
17563
17564 elsif Nkind (P) = N_Identifier
17565 and then Nkind (Parent (Entity (P))) = N_Object_Declaration
17566 and then Present (Expression (Parent (Entity (P))))
17567 and then Nkind (Expression (Parent (Entity (P)))) =
17568 N_Reference
17569 then
17570 -- Case of a reference to a value on which side effects have
17571 -- been removed.
17572
17573 Exp := Prefix (Expression (Parent (Entity (P))));
17574 goto Continue;
17575
17576 else
17577 return;
17578 end if;
17579 end;
17580
17581 elsif Nkind_In (Exp, N_Type_Conversion,
17582 N_Unchecked_Type_Conversion)
17583 then
17584 Exp := Expression (Exp);
17585 goto Continue;
17586
17587 elsif Nkind_In (Exp, N_Slice,
17588 N_Indexed_Component,
17589 N_Selected_Component)
17590 then
17591 -- Special check, if the prefix is an access type, then return
17592 -- since we are modifying the thing pointed to, not the prefix.
17593 -- When we are expanding, most usually the prefix is replaced
17594 -- by an explicit dereference, and this test is not needed, but
17595 -- in some cases (notably -gnatc mode and generics) when we do
17596 -- not do full expansion, we need this special test.
17597
17598 if Is_Access_Type (Etype (Prefix (Exp))) then
17599 return;
17600
17601 -- Otherwise go to prefix and keep going
17602
17603 else
17604 Exp := Prefix (Exp);
17605 goto Continue;
17606 end if;
17607
17608 -- All other cases, not a modification
17609
17610 else
17611 return;
17612 end if;
17613
17614 -- Now look for entity being referenced
17615
17616 if Present (Ent) then
17617 if Is_Object (Ent) then
17618 if Comes_From_Source (Exp)
17619 or else Modification_Comes_From_Source
17620 then
17621 -- Give warning if pragma unmodified is given and we are
17622 -- sure this is a modification.
17623
17624 if Has_Pragma_Unmodified (Ent) and then Sure then
17625
17626 -- Note that the entity may be present only as a result
17627 -- of pragma Unused.
17628
17629 if Has_Pragma_Unused (Ent) then
17630 Error_Msg_NE ("??pragma Unused given for &!", N, Ent);
17631 else
17632 Error_Msg_NE
17633 ("??pragma Unmodified given for &!", N, Ent);
17634 end if;
17635 end if;
17636
17637 Set_Never_Set_In_Source (Ent, False);
17638 end if;
17639
17640 Set_Is_True_Constant (Ent, False);
17641 Set_Current_Value (Ent, Empty);
17642 Set_Is_Known_Null (Ent, False);
17643
17644 if not Can_Never_Be_Null (Ent) then
17645 Set_Is_Known_Non_Null (Ent, False);
17646 end if;
17647
17648 -- Follow renaming chain
17649
17650 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
17651 and then Present (Renamed_Object (Ent))
17652 then
17653 Exp := Renamed_Object (Ent);
17654
17655 -- If the entity is the loop variable in an iteration over
17656 -- a container, retrieve container expression to indicate
17657 -- possible modification.
17658
17659 if Present (Related_Expression (Ent))
17660 and then Nkind (Parent (Related_Expression (Ent))) =
17661 N_Iterator_Specification
17662 then
17663 Exp := Original_Node (Related_Expression (Ent));
17664 end if;
17665
17666 goto Continue;
17667
17668 -- The expression may be the renaming of a subcomponent of an
17669 -- array or container. The assignment to the subcomponent is
17670 -- a modification of the container.
17671
17672 elsif Comes_From_Source (Original_Node (Exp))
17673 and then Nkind_In (Original_Node (Exp), N_Selected_Component,
17674 N_Indexed_Component)
17675 then
17676 Exp := Prefix (Original_Node (Exp));
17677 goto Continue;
17678 end if;
17679
17680 -- Generate a reference only if the assignment comes from
17681 -- source. This excludes, for example, calls to a dispatching
17682 -- assignment operation when the left-hand side is tagged. In
17683 -- GNATprove mode, we need those references also on generated
17684 -- code, as these are used to compute the local effects of
17685 -- subprograms.
17686
17687 if Modification_Comes_From_Source or GNATprove_Mode then
17688 Generate_Reference (Ent, Exp, 'm');
17689
17690 -- If the target of the assignment is the bound variable
17691 -- in an iterator, indicate that the corresponding array
17692 -- or container is also modified.
17693
17694 if Ada_Version >= Ada_2012
17695 and then Nkind (Parent (Ent)) = N_Iterator_Specification
17696 then
17697 declare
17698 Domain : constant Node_Id := Name (Parent (Ent));
17699
17700 begin
17701 -- TBD : in the full version of the construct, the
17702 -- domain of iteration can be given by an expression.
17703
17704 if Is_Entity_Name (Domain) then
17705 Generate_Reference (Entity (Domain), Exp, 'm');
17706 Set_Is_True_Constant (Entity (Domain), False);
17707 Set_Never_Set_In_Source (Entity (Domain), False);
17708 end if;
17709 end;
17710 end if;
17711 end if;
17712 end if;
17713
17714 Kill_Checks (Ent);
17715
17716 -- If we are sure this is a modification from source, and we know
17717 -- this modifies a constant, then give an appropriate warning.
17718
17719 if Sure
17720 and then Modification_Comes_From_Source
17721 and then Overlays_Constant (Ent)
17722 and then Address_Clause_Overlay_Warnings
17723 then
17724 declare
17725 Addr : constant Node_Id := Address_Clause (Ent);
17726 O_Ent : Entity_Id;
17727 Off : Boolean;
17728
17729 begin
17730 Find_Overlaid_Entity (Addr, O_Ent, Off);
17731
17732 Error_Msg_Sloc := Sloc (Addr);
17733 Error_Msg_NE
17734 ("??constant& may be modified via address clause#",
17735 N, O_Ent);
17736 end;
17737 end if;
17738
17739 return;
17740 end if;
17741
17742 <<Continue>>
17743 null;
17744 end loop;
17745 end Note_Possible_Modification;
17746
17747 --------------------------------------
17748 -- Null_To_Null_Address_Convert_OK --
17749 --------------------------------------
17750
17751 function Null_To_Null_Address_Convert_OK
17752 (N : Node_Id;
17753 Typ : Entity_Id := Empty) return Boolean
17754 is
17755 begin
17756 if not Relaxed_RM_Semantics then
17757 return False;
17758 end if;
17759
17760 if Nkind (N) = N_Null then
17761 return Present (Typ) and then Is_Descendant_Of_Address (Typ);
17762
17763 elsif Nkind_In (N, N_Op_Eq, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt, N_Op_Ne)
17764 then
17765 declare
17766 L : constant Node_Id := Left_Opnd (N);
17767 R : constant Node_Id := Right_Opnd (N);
17768
17769 begin
17770 -- We check the Etype of the complementary operand since the
17771 -- N_Null node is not decorated at this stage.
17772
17773 return
17774 ((Nkind (L) = N_Null
17775 and then Is_Descendant_Of_Address (Etype (R)))
17776 or else
17777 (Nkind (R) = N_Null
17778 and then Is_Descendant_Of_Address (Etype (L))));
17779 end;
17780 end if;
17781
17782 return False;
17783 end Null_To_Null_Address_Convert_OK;
17784
17785 -------------------------
17786 -- Object_Access_Level --
17787 -------------------------
17788
17789 -- Returns the static accessibility level of the view denoted by Obj. Note
17790 -- that the value returned is the result of a call to Scope_Depth. Only
17791 -- scope depths associated with dynamic scopes can actually be returned.
17792 -- Since only relative levels matter for accessibility checking, the fact
17793 -- that the distance between successive levels of accessibility is not
17794 -- always one is immaterial (invariant: if level(E2) is deeper than
17795 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
17796
17797 function Object_Access_Level (Obj : Node_Id) return Uint is
17798 function Is_Interface_Conversion (N : Node_Id) return Boolean;
17799 -- Determine whether N is a construct of the form
17800 -- Some_Type (Operand._tag'Address)
17801 -- This construct appears in the context of dispatching calls.
17802
17803 function Reference_To (Obj : Node_Id) return Node_Id;
17804 -- An explicit dereference is created when removing side-effects from
17805 -- expressions for constraint checking purposes. In this case a local
17806 -- access type is created for it. The correct access level is that of
17807 -- the original source node. We detect this case by noting that the
17808 -- prefix of the dereference is created by an object declaration whose
17809 -- initial expression is a reference.
17810
17811 -----------------------------
17812 -- Is_Interface_Conversion --
17813 -----------------------------
17814
17815 function Is_Interface_Conversion (N : Node_Id) return Boolean is
17816 begin
17817 return Nkind (N) = N_Unchecked_Type_Conversion
17818 and then Nkind (Expression (N)) = N_Attribute_Reference
17819 and then Attribute_Name (Expression (N)) = Name_Address;
17820 end Is_Interface_Conversion;
17821
17822 ------------------
17823 -- Reference_To --
17824 ------------------
17825
17826 function Reference_To (Obj : Node_Id) return Node_Id is
17827 Pref : constant Node_Id := Prefix (Obj);
17828 begin
17829 if Is_Entity_Name (Pref)
17830 and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
17831 and then Present (Expression (Parent (Entity (Pref))))
17832 and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
17833 then
17834 return (Prefix (Expression (Parent (Entity (Pref)))));
17835 else
17836 return Empty;
17837 end if;
17838 end Reference_To;
17839
17840 -- Local variables
17841
17842 E : Entity_Id;
17843
17844 -- Start of processing for Object_Access_Level
17845
17846 begin
17847 if Nkind (Obj) = N_Defining_Identifier
17848 or else Is_Entity_Name (Obj)
17849 then
17850 if Nkind (Obj) = N_Defining_Identifier then
17851 E := Obj;
17852 else
17853 E := Entity (Obj);
17854 end if;
17855
17856 if Is_Prival (E) then
17857 E := Prival_Link (E);
17858 end if;
17859
17860 -- If E is a type then it denotes a current instance. For this case
17861 -- we add one to the normal accessibility level of the type to ensure
17862 -- that current instances are treated as always being deeper than
17863 -- than the level of any visible named access type (see 3.10.2(21)).
17864
17865 if Is_Type (E) then
17866 return Type_Access_Level (E) + 1;
17867
17868 elsif Present (Renamed_Object (E)) then
17869 return Object_Access_Level (Renamed_Object (E));
17870
17871 -- Similarly, if E is a component of the current instance of a
17872 -- protected type, any instance of it is assumed to be at a deeper
17873 -- level than the type. For a protected object (whose type is an
17874 -- anonymous protected type) its components are at the same level
17875 -- as the type itself.
17876
17877 elsif not Is_Overloadable (E)
17878 and then Ekind (Scope (E)) = E_Protected_Type
17879 and then Comes_From_Source (Scope (E))
17880 then
17881 return Type_Access_Level (Scope (E)) + 1;
17882
17883 else
17884 -- Aliased formals of functions take their access level from the
17885 -- point of call, i.e. require a dynamic check. For static check
17886 -- purposes, this is smaller than the level of the subprogram
17887 -- itself. For procedures the aliased makes no difference.
17888
17889 if Is_Formal (E)
17890 and then Is_Aliased (E)
17891 and then Ekind (Scope (E)) = E_Function
17892 then
17893 return Type_Access_Level (Etype (E));
17894
17895 else
17896 return Scope_Depth (Enclosing_Dynamic_Scope (E));
17897 end if;
17898 end if;
17899
17900 elsif Nkind (Obj) = N_Selected_Component then
17901 if Is_Access_Type (Etype (Prefix (Obj))) then
17902 return Type_Access_Level (Etype (Prefix (Obj)));
17903 else
17904 return Object_Access_Level (Prefix (Obj));
17905 end if;
17906
17907 elsif Nkind (Obj) = N_Indexed_Component then
17908 if Is_Access_Type (Etype (Prefix (Obj))) then
17909 return Type_Access_Level (Etype (Prefix (Obj)));
17910 else
17911 return Object_Access_Level (Prefix (Obj));
17912 end if;
17913
17914 elsif Nkind (Obj) = N_Explicit_Dereference then
17915
17916 -- If the prefix is a selected access discriminant then we make a
17917 -- recursive call on the prefix, which will in turn check the level
17918 -- of the prefix object of the selected discriminant.
17919
17920 -- In Ada 2012, if the discriminant has implicit dereference and
17921 -- the context is a selected component, treat this as an object of
17922 -- unknown scope (see below). This is necessary in compile-only mode;
17923 -- otherwise expansion will already have transformed the prefix into
17924 -- a temporary.
17925
17926 if Nkind (Prefix (Obj)) = N_Selected_Component
17927 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
17928 and then
17929 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
17930 and then
17931 (not Has_Implicit_Dereference
17932 (Entity (Selector_Name (Prefix (Obj))))
17933 or else Nkind (Parent (Obj)) /= N_Selected_Component)
17934 then
17935 return Object_Access_Level (Prefix (Obj));
17936
17937 -- Detect an interface conversion in the context of a dispatching
17938 -- call. Use the original form of the conversion to find the access
17939 -- level of the operand.
17940
17941 elsif Is_Interface (Etype (Obj))
17942 and then Is_Interface_Conversion (Prefix (Obj))
17943 and then Nkind (Original_Node (Obj)) = N_Type_Conversion
17944 then
17945 return Object_Access_Level (Original_Node (Obj));
17946
17947 elsif not Comes_From_Source (Obj) then
17948 declare
17949 Ref : constant Node_Id := Reference_To (Obj);
17950 begin
17951 if Present (Ref) then
17952 return Object_Access_Level (Ref);
17953 else
17954 return Type_Access_Level (Etype (Prefix (Obj)));
17955 end if;
17956 end;
17957
17958 else
17959 return Type_Access_Level (Etype (Prefix (Obj)));
17960 end if;
17961
17962 elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
17963 return Object_Access_Level (Expression (Obj));
17964
17965 elsif Nkind (Obj) = N_Function_Call then
17966
17967 -- Function results are objects, so we get either the access level of
17968 -- the function or, in the case of an indirect call, the level of the
17969 -- access-to-subprogram type. (This code is used for Ada 95, but it
17970 -- looks wrong, because it seems that we should be checking the level
17971 -- of the call itself, even for Ada 95. However, using the Ada 2005
17972 -- version of the code causes regressions in several tests that are
17973 -- compiled with -gnat95. ???)
17974
17975 if Ada_Version < Ada_2005 then
17976 if Is_Entity_Name (Name (Obj)) then
17977 return Subprogram_Access_Level (Entity (Name (Obj)));
17978 else
17979 return Type_Access_Level (Etype (Prefix (Name (Obj))));
17980 end if;
17981
17982 -- For Ada 2005, the level of the result object of a function call is
17983 -- defined to be the level of the call's innermost enclosing master.
17984 -- We determine that by querying the depth of the innermost enclosing
17985 -- dynamic scope.
17986
17987 else
17988 Return_Master_Scope_Depth_Of_Call : declare
17989
17990 function Innermost_Master_Scope_Depth
17991 (N : Node_Id) return Uint;
17992 -- Returns the scope depth of the given node's innermost
17993 -- enclosing dynamic scope (effectively the accessibility
17994 -- level of the innermost enclosing master).
17995
17996 ----------------------------------
17997 -- Innermost_Master_Scope_Depth --
17998 ----------------------------------
17999
18000 function Innermost_Master_Scope_Depth
18001 (N : Node_Id) return Uint
18002 is
18003 Node_Par : Node_Id := Parent (N);
18004
18005 begin
18006 -- Locate the nearest enclosing node (by traversing Parents)
18007 -- that Defining_Entity can be applied to, and return the
18008 -- depth of that entity's nearest enclosing dynamic scope.
18009
18010 while Present (Node_Par) loop
18011 case Nkind (Node_Par) is
18012 when N_Component_Declaration |
18013 N_Entry_Declaration |
18014 N_Formal_Object_Declaration |
18015 N_Formal_Type_Declaration |
18016 N_Full_Type_Declaration |
18017 N_Incomplete_Type_Declaration |
18018 N_Loop_Parameter_Specification |
18019 N_Object_Declaration |
18020 N_Protected_Type_Declaration |
18021 N_Private_Extension_Declaration |
18022 N_Private_Type_Declaration |
18023 N_Subtype_Declaration |
18024 N_Function_Specification |
18025 N_Procedure_Specification |
18026 N_Task_Type_Declaration |
18027 N_Body_Stub |
18028 N_Generic_Instantiation |
18029 N_Proper_Body |
18030 N_Implicit_Label_Declaration |
18031 N_Package_Declaration |
18032 N_Single_Task_Declaration |
18033 N_Subprogram_Declaration |
18034 N_Generic_Declaration |
18035 N_Renaming_Declaration |
18036 N_Block_Statement |
18037 N_Formal_Subprogram_Declaration |
18038 N_Abstract_Subprogram_Declaration |
18039 N_Entry_Body |
18040 N_Exception_Declaration |
18041 N_Formal_Package_Declaration |
18042 N_Number_Declaration |
18043 N_Package_Specification |
18044 N_Parameter_Specification |
18045 N_Single_Protected_Declaration |
18046 N_Subunit =>
18047
18048 return Scope_Depth
18049 (Nearest_Dynamic_Scope
18050 (Defining_Entity (Node_Par)));
18051
18052 when others =>
18053 null;
18054 end case;
18055
18056 Node_Par := Parent (Node_Par);
18057 end loop;
18058
18059 pragma Assert (False);
18060
18061 -- Should never reach the following return
18062
18063 return Scope_Depth (Current_Scope) + 1;
18064 end Innermost_Master_Scope_Depth;
18065
18066 -- Start of processing for Return_Master_Scope_Depth_Of_Call
18067
18068 begin
18069 return Innermost_Master_Scope_Depth (Obj);
18070 end Return_Master_Scope_Depth_Of_Call;
18071 end if;
18072
18073 -- For convenience we handle qualified expressions, even though they
18074 -- aren't technically object names.
18075
18076 elsif Nkind (Obj) = N_Qualified_Expression then
18077 return Object_Access_Level (Expression (Obj));
18078
18079 -- Ditto for aggregates. They have the level of the temporary that
18080 -- will hold their value.
18081
18082 elsif Nkind (Obj) = N_Aggregate then
18083 return Object_Access_Level (Current_Scope);
18084
18085 -- Otherwise return the scope level of Standard. (If there are cases
18086 -- that fall through to this point they will be treated as having
18087 -- global accessibility for now. ???)
18088
18089 else
18090 return Scope_Depth (Standard_Standard);
18091 end if;
18092 end Object_Access_Level;
18093
18094 ---------------------------------
18095 -- Original_Aspect_Pragma_Name --
18096 ---------------------------------
18097
18098 function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is
18099 Item : Node_Id;
18100 Item_Nam : Name_Id;
18101
18102 begin
18103 pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma));
18104
18105 Item := N;
18106
18107 -- The pragma was generated to emulate an aspect, use the original
18108 -- aspect specification.
18109
18110 if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then
18111 Item := Corresponding_Aspect (Item);
18112 end if;
18113
18114 -- Retrieve the name of the aspect/pragma. Note that Pre, Pre_Class,
18115 -- Post and Post_Class rewrite their pragma identifier to preserve the
18116 -- original name.
18117 -- ??? this is kludgey
18118
18119 if Nkind (Item) = N_Pragma then
18120 Item_Nam := Chars (Original_Node (Pragma_Identifier (Item)));
18121
18122 else
18123 pragma Assert (Nkind (Item) = N_Aspect_Specification);
18124 Item_Nam := Chars (Identifier (Item));
18125 end if;
18126
18127 -- Deal with 'Class by converting the name to its _XXX form
18128
18129 if Class_Present (Item) then
18130 if Item_Nam = Name_Invariant then
18131 Item_Nam := Name_uInvariant;
18132
18133 elsif Item_Nam = Name_Post then
18134 Item_Nam := Name_uPost;
18135
18136 elsif Item_Nam = Name_Pre then
18137 Item_Nam := Name_uPre;
18138
18139 elsif Nam_In (Item_Nam, Name_Type_Invariant,
18140 Name_Type_Invariant_Class)
18141 then
18142 Item_Nam := Name_uType_Invariant;
18143
18144 -- Nothing to do for other cases (e.g. a Check that derived from
18145 -- Pre_Class and has the flag set). Also we do nothing if the name
18146 -- is already in special _xxx form.
18147
18148 end if;
18149 end if;
18150
18151 return Item_Nam;
18152 end Original_Aspect_Pragma_Name;
18153
18154 --------------------------------------
18155 -- Original_Corresponding_Operation --
18156 --------------------------------------
18157
18158 function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
18159 is
18160 Typ : constant Entity_Id := Find_Dispatching_Type (S);
18161
18162 begin
18163 -- If S is an inherited primitive S2 the original corresponding
18164 -- operation of S is the original corresponding operation of S2
18165
18166 if Present (Alias (S))
18167 and then Find_Dispatching_Type (Alias (S)) /= Typ
18168 then
18169 return Original_Corresponding_Operation (Alias (S));
18170
18171 -- If S overrides an inherited subprogram S2 the original corresponding
18172 -- operation of S is the original corresponding operation of S2
18173
18174 elsif Present (Overridden_Operation (S)) then
18175 return Original_Corresponding_Operation (Overridden_Operation (S));
18176
18177 -- otherwise it is S itself
18178
18179 else
18180 return S;
18181 end if;
18182 end Original_Corresponding_Operation;
18183
18184 -------------------
18185 -- Output_Entity --
18186 -------------------
18187
18188 procedure Output_Entity (Id : Entity_Id) is
18189 Scop : Entity_Id;
18190
18191 begin
18192 Scop := Scope (Id);
18193
18194 -- The entity may lack a scope when it is in the process of being
18195 -- analyzed. Use the current scope as an approximation.
18196
18197 if No (Scop) then
18198 Scop := Current_Scope;
18199 end if;
18200
18201 Output_Name (Chars (Id), Scop);
18202 end Output_Entity;
18203
18204 -----------------
18205 -- Output_Name --
18206 -----------------
18207
18208 procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is
18209 begin
18210 Write_Str
18211 (Get_Name_String
18212 (Get_Qualified_Name
18213 (Nam => Nam,
18214 Suffix => No_Name,
18215 Scop => Scop)));
18216 Write_Eol;
18217 end Output_Name;
18218
18219 ----------------------
18220 -- Policy_In_Effect --
18221 ----------------------
18222
18223 function Policy_In_Effect (Policy : Name_Id) return Name_Id is
18224 function Policy_In_List (List : Node_Id) return Name_Id;
18225 -- Determine the mode of a policy in a N_Pragma list
18226
18227 --------------------
18228 -- Policy_In_List --
18229 --------------------
18230
18231 function Policy_In_List (List : Node_Id) return Name_Id is
18232 Arg1 : Node_Id;
18233 Arg2 : Node_Id;
18234 Prag : Node_Id;
18235
18236 begin
18237 Prag := List;
18238 while Present (Prag) loop
18239 Arg1 := First (Pragma_Argument_Associations (Prag));
18240 Arg2 := Next (Arg1);
18241
18242 Arg1 := Get_Pragma_Arg (Arg1);
18243 Arg2 := Get_Pragma_Arg (Arg2);
18244
18245 -- The current Check_Policy pragma matches the requested policy or
18246 -- appears in the single argument form (Assertion, policy_id).
18247
18248 if Nam_In (Chars (Arg1), Name_Assertion, Policy) then
18249 return Chars (Arg2);
18250 end if;
18251
18252 Prag := Next_Pragma (Prag);
18253 end loop;
18254
18255 return No_Name;
18256 end Policy_In_List;
18257
18258 -- Local variables
18259
18260 Kind : Name_Id;
18261
18262 -- Start of processing for Policy_In_Effect
18263
18264 begin
18265 if not Is_Valid_Assertion_Kind (Policy) then
18266 raise Program_Error;
18267 end if;
18268
18269 -- Inspect all policy pragmas that appear within scopes (if any)
18270
18271 Kind := Policy_In_List (Check_Policy_List);
18272
18273 -- Inspect all configuration policy pragmas (if any)
18274
18275 if Kind = No_Name then
18276 Kind := Policy_In_List (Check_Policy_List_Config);
18277 end if;
18278
18279 -- The context lacks policy pragmas, determine the mode based on whether
18280 -- assertions are enabled at the configuration level. This ensures that
18281 -- the policy is preserved when analyzing generics.
18282
18283 if Kind = No_Name then
18284 if Assertions_Enabled_Config then
18285 Kind := Name_Check;
18286 else
18287 Kind := Name_Ignore;
18288 end if;
18289 end if;
18290
18291 return Kind;
18292 end Policy_In_Effect;
18293
18294 ----------------------------------
18295 -- Predicate_Tests_On_Arguments --
18296 ----------------------------------
18297
18298 function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is
18299 begin
18300 -- Always test predicates on indirect call
18301
18302 if Ekind (Subp) = E_Subprogram_Type then
18303 return True;
18304
18305 -- Do not test predicates on call to generated default Finalize, since
18306 -- we are not interested in whether something we are finalizing (and
18307 -- typically destroying) satisfies its predicates.
18308
18309 elsif Chars (Subp) = Name_Finalize
18310 and then not Comes_From_Source (Subp)
18311 then
18312 return False;
18313
18314 -- Do not test predicates on any internally generated routines
18315
18316 elsif Is_Internal_Name (Chars (Subp)) then
18317 return False;
18318
18319 -- Do not test predicates on call to Init_Proc, since if needed the
18320 -- predicate test will occur at some other point.
18321
18322 elsif Is_Init_Proc (Subp) then
18323 return False;
18324
18325 -- Do not test predicates on call to predicate function, since this
18326 -- would cause infinite recursion.
18327
18328 elsif Ekind (Subp) = E_Function
18329 and then (Is_Predicate_Function (Subp)
18330 or else
18331 Is_Predicate_Function_M (Subp))
18332 then
18333 return False;
18334
18335 -- For now, no other exceptions
18336
18337 else
18338 return True;
18339 end if;
18340 end Predicate_Tests_On_Arguments;
18341
18342 -----------------------
18343 -- Private_Component --
18344 -----------------------
18345
18346 function Private_Component (Type_Id : Entity_Id) return Entity_Id is
18347 Ancestor : constant Entity_Id := Base_Type (Type_Id);
18348
18349 function Trace_Components
18350 (T : Entity_Id;
18351 Check : Boolean) return Entity_Id;
18352 -- Recursive function that does the work, and checks against circular
18353 -- definition for each subcomponent type.
18354
18355 ----------------------
18356 -- Trace_Components --
18357 ----------------------
18358
18359 function Trace_Components
18360 (T : Entity_Id;
18361 Check : Boolean) return Entity_Id
18362 is
18363 Btype : constant Entity_Id := Base_Type (T);
18364 Component : Entity_Id;
18365 P : Entity_Id;
18366 Candidate : Entity_Id := Empty;
18367
18368 begin
18369 if Check and then Btype = Ancestor then
18370 Error_Msg_N ("circular type definition", Type_Id);
18371 return Any_Type;
18372 end if;
18373
18374 if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then
18375 if Present (Full_View (Btype))
18376 and then Is_Record_Type (Full_View (Btype))
18377 and then not Is_Frozen (Btype)
18378 then
18379 -- To indicate that the ancestor depends on a private type, the
18380 -- current Btype is sufficient. However, to check for circular
18381 -- definition we must recurse on the full view.
18382
18383 Candidate := Trace_Components (Full_View (Btype), True);
18384
18385 if Candidate = Any_Type then
18386 return Any_Type;
18387 else
18388 return Btype;
18389 end if;
18390
18391 else
18392 return Btype;
18393 end if;
18394
18395 elsif Is_Array_Type (Btype) then
18396 return Trace_Components (Component_Type (Btype), True);
18397
18398 elsif Is_Record_Type (Btype) then
18399 Component := First_Entity (Btype);
18400 while Present (Component)
18401 and then Comes_From_Source (Component)
18402 loop
18403 -- Skip anonymous types generated by constrained components
18404
18405 if not Is_Type (Component) then
18406 P := Trace_Components (Etype (Component), True);
18407
18408 if Present (P) then
18409 if P = Any_Type then
18410 return P;
18411 else
18412 Candidate := P;
18413 end if;
18414 end if;
18415 end if;
18416
18417 Next_Entity (Component);
18418 end loop;
18419
18420 return Candidate;
18421
18422 else
18423 return Empty;
18424 end if;
18425 end Trace_Components;
18426
18427 -- Start of processing for Private_Component
18428
18429 begin
18430 return Trace_Components (Type_Id, False);
18431 end Private_Component;
18432
18433 ---------------------------
18434 -- Primitive_Names_Match --
18435 ---------------------------
18436
18437 function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
18438
18439 function Non_Internal_Name (E : Entity_Id) return Name_Id;
18440 -- Given an internal name, returns the corresponding non-internal name
18441
18442 ------------------------
18443 -- Non_Internal_Name --
18444 ------------------------
18445
18446 function Non_Internal_Name (E : Entity_Id) return Name_Id is
18447 begin
18448 Get_Name_String (Chars (E));
18449 Name_Len := Name_Len - 1;
18450 return Name_Find;
18451 end Non_Internal_Name;
18452
18453 -- Start of processing for Primitive_Names_Match
18454
18455 begin
18456 pragma Assert (Present (E1) and then Present (E2));
18457
18458 return Chars (E1) = Chars (E2)
18459 or else
18460 (not Is_Internal_Name (Chars (E1))
18461 and then Is_Internal_Name (Chars (E2))
18462 and then Non_Internal_Name (E2) = Chars (E1))
18463 or else
18464 (not Is_Internal_Name (Chars (E2))
18465 and then Is_Internal_Name (Chars (E1))
18466 and then Non_Internal_Name (E1) = Chars (E2))
18467 or else
18468 (Is_Predefined_Dispatching_Operation (E1)
18469 and then Is_Predefined_Dispatching_Operation (E2)
18470 and then Same_TSS (E1, E2))
18471 or else
18472 (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
18473 end Primitive_Names_Match;
18474
18475 -----------------------
18476 -- Process_End_Label --
18477 -----------------------
18478
18479 procedure Process_End_Label
18480 (N : Node_Id;
18481 Typ : Character;
18482 Ent : Entity_Id)
18483 is
18484 Loc : Source_Ptr;
18485 Nam : Node_Id;
18486 Scop : Entity_Id;
18487
18488 Label_Ref : Boolean;
18489 -- Set True if reference to end label itself is required
18490
18491 Endl : Node_Id;
18492 -- Gets set to the operator symbol or identifier that references the
18493 -- entity Ent. For the child unit case, this is the identifier from the
18494 -- designator. For other cases, this is simply Endl.
18495
18496 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
18497 -- N is an identifier node that appears as a parent unit reference in
18498 -- the case where Ent is a child unit. This procedure generates an
18499 -- appropriate cross-reference entry. E is the corresponding entity.
18500
18501 -------------------------
18502 -- Generate_Parent_Ref --
18503 -------------------------
18504
18505 procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
18506 begin
18507 -- If names do not match, something weird, skip reference
18508
18509 if Chars (E) = Chars (N) then
18510
18511 -- Generate the reference. We do NOT consider this as a reference
18512 -- for unreferenced symbol purposes.
18513
18514 Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
18515
18516 if Style_Check then
18517 Style.Check_Identifier (N, E);
18518 end if;
18519 end if;
18520 end Generate_Parent_Ref;
18521
18522 -- Start of processing for Process_End_Label
18523
18524 begin
18525 -- If no node, ignore. This happens in some error situations, and
18526 -- also for some internally generated structures where no end label
18527 -- references are required in any case.
18528
18529 if No (N) then
18530 return;
18531 end if;
18532
18533 -- Nothing to do if no End_Label, happens for internally generated
18534 -- constructs where we don't want an end label reference anyway. Also
18535 -- nothing to do if Endl is a string literal, which means there was
18536 -- some prior error (bad operator symbol)
18537
18538 Endl := End_Label (N);
18539
18540 if No (Endl) or else Nkind (Endl) = N_String_Literal then
18541 return;
18542 end if;
18543
18544 -- Reference node is not in extended main source unit
18545
18546 if not In_Extended_Main_Source_Unit (N) then
18547
18548 -- Generally we do not collect references except for the extended
18549 -- main source unit. The one exception is the 'e' entry for a
18550 -- package spec, where it is useful for a client to have the
18551 -- ending information to define scopes.
18552
18553 if Typ /= 'e' then
18554 return;
18555
18556 else
18557 Label_Ref := False;
18558
18559 -- For this case, we can ignore any parent references, but we
18560 -- need the package name itself for the 'e' entry.
18561
18562 if Nkind (Endl) = N_Designator then
18563 Endl := Identifier (Endl);
18564 end if;
18565 end if;
18566
18567 -- Reference is in extended main source unit
18568
18569 else
18570 Label_Ref := True;
18571
18572 -- For designator, generate references for the parent entries
18573
18574 if Nkind (Endl) = N_Designator then
18575
18576 -- Generate references for the prefix if the END line comes from
18577 -- source (otherwise we do not need these references) We climb the
18578 -- scope stack to find the expected entities.
18579
18580 if Comes_From_Source (Endl) then
18581 Nam := Name (Endl);
18582 Scop := Current_Scope;
18583 while Nkind (Nam) = N_Selected_Component loop
18584 Scop := Scope (Scop);
18585 exit when No (Scop);
18586 Generate_Parent_Ref (Selector_Name (Nam), Scop);
18587 Nam := Prefix (Nam);
18588 end loop;
18589
18590 if Present (Scop) then
18591 Generate_Parent_Ref (Nam, Scope (Scop));
18592 end if;
18593 end if;
18594
18595 Endl := Identifier (Endl);
18596 end if;
18597 end if;
18598
18599 -- If the end label is not for the given entity, then either we have
18600 -- some previous error, or this is a generic instantiation for which
18601 -- we do not need to make a cross-reference in this case anyway. In
18602 -- either case we simply ignore the call.
18603
18604 if Chars (Ent) /= Chars (Endl) then
18605 return;
18606 end if;
18607
18608 -- If label was really there, then generate a normal reference and then
18609 -- adjust the location in the end label to point past the name (which
18610 -- should almost always be the semicolon).
18611
18612 Loc := Sloc (Endl);
18613
18614 if Comes_From_Source (Endl) then
18615
18616 -- If a label reference is required, then do the style check and
18617 -- generate an l-type cross-reference entry for the label
18618
18619 if Label_Ref then
18620 if Style_Check then
18621 Style.Check_Identifier (Endl, Ent);
18622 end if;
18623
18624 Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
18625 end if;
18626
18627 -- Set the location to point past the label (normally this will
18628 -- mean the semicolon immediately following the label). This is
18629 -- done for the sake of the 'e' or 't' entry generated below.
18630
18631 Get_Decoded_Name_String (Chars (Endl));
18632 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
18633
18634 else
18635 -- In SPARK mode, no missing label is allowed for packages and
18636 -- subprogram bodies. Detect those cases by testing whether
18637 -- Process_End_Label was called for a body (Typ = 't') or a package.
18638
18639 if Restriction_Check_Required (SPARK_05)
18640 and then (Typ = 't' or else Ekind (Ent) = E_Package)
18641 then
18642 Error_Msg_Node_1 := Endl;
18643 Check_SPARK_05_Restriction
18644 ("`END &` required", Endl, Force => True);
18645 end if;
18646 end if;
18647
18648 -- Now generate the e/t reference
18649
18650 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
18651
18652 -- Restore Sloc, in case modified above, since we have an identifier
18653 -- and the normal Sloc should be left set in the tree.
18654
18655 Set_Sloc (Endl, Loc);
18656 end Process_End_Label;
18657
18658 ------------------------------------
18659 -- Propagate_Invariant_Attributes --
18660 ------------------------------------
18661
18662 procedure Propagate_Invariant_Attributes
18663 (Typ : Entity_Id;
18664 From_Typ : Entity_Id)
18665 is
18666 Full_IP : Entity_Id;
18667 Part_IP : Entity_Id;
18668
18669 begin
18670 if Present (Typ) and then Present (From_Typ) then
18671 pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ));
18672
18673 -- Nothing to do if both the source and the destination denote the
18674 -- same type.
18675
18676 if From_Typ = Typ then
18677 return;
18678 end if;
18679
18680 Full_IP := Invariant_Procedure (From_Typ);
18681 Part_IP := Partial_Invariant_Procedure (From_Typ);
18682
18683 -- The setting of the attributes is intentionally conservative. This
18684 -- prevents accidental clobbering of enabled attributes.
18685
18686 if Has_Inheritable_Invariants (From_Typ)
18687 and then not Has_Inheritable_Invariants (Typ)
18688 then
18689 Set_Has_Inheritable_Invariants (Typ, True);
18690 end if;
18691
18692 if Has_Inherited_Invariants (From_Typ)
18693 and then not Has_Inherited_Invariants (Typ)
18694 then
18695 Set_Has_Inherited_Invariants (Typ, True);
18696 end if;
18697
18698 if Has_Own_Invariants (From_Typ)
18699 and then not Has_Own_Invariants (Typ)
18700 then
18701 Set_Has_Own_Invariants (Typ, True);
18702 end if;
18703
18704 if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then
18705 Set_Invariant_Procedure (Typ, Full_IP);
18706 end if;
18707
18708 if Present (Part_IP) and then No (Partial_Invariant_Procedure (Typ))
18709 then
18710 Set_Partial_Invariant_Procedure (Typ, Part_IP);
18711 end if;
18712 end if;
18713 end Propagate_Invariant_Attributes;
18714
18715 --------------------------------
18716 -- Propagate_Concurrent_Flags --
18717 --------------------------------
18718
18719 procedure Propagate_Concurrent_Flags
18720 (Typ : Entity_Id;
18721 Comp_Typ : Entity_Id)
18722 is
18723 begin
18724 if Has_Task (Comp_Typ) then
18725 Set_Has_Task (Typ);
18726 end if;
18727
18728 if Has_Protected (Comp_Typ) then
18729 Set_Has_Protected (Typ);
18730 end if;
18731
18732 if Has_Timing_Event (Comp_Typ) then
18733 Set_Has_Timing_Event (Typ);
18734 end if;
18735 end Propagate_Concurrent_Flags;
18736
18737 ---------------------------------------
18738 -- Record_Possible_Part_Of_Reference --
18739 ---------------------------------------
18740
18741 procedure Record_Possible_Part_Of_Reference
18742 (Var_Id : Entity_Id;
18743 Ref : Node_Id)
18744 is
18745 Encap : constant Entity_Id := Encapsulating_State (Var_Id);
18746 Refs : Elist_Id;
18747
18748 begin
18749 -- The variable is a constituent of a single protected/task type. Such
18750 -- a variable acts as a component of the type and must appear within a
18751 -- specific region (SPARK RM 9.3). Instead of recording the reference,
18752 -- verify its legality now.
18753
18754 if Present (Encap) and then Is_Single_Concurrent_Object (Encap) then
18755 Check_Part_Of_Reference (Var_Id, Ref);
18756
18757 -- The variable is subject to pragma Part_Of and may eventually become a
18758 -- constituent of a single protected/task type. Record the reference to
18759 -- verify its placement when the contract of the variable is analyzed.
18760
18761 elsif Present (Get_Pragma (Var_Id, Pragma_Part_Of)) then
18762 Refs := Part_Of_References (Var_Id);
18763
18764 if No (Refs) then
18765 Refs := New_Elmt_List;
18766 Set_Part_Of_References (Var_Id, Refs);
18767 end if;
18768
18769 Append_Elmt (Ref, Refs);
18770 end if;
18771 end Record_Possible_Part_Of_Reference;
18772
18773 ----------------
18774 -- Referenced --
18775 ----------------
18776
18777 function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is
18778 Seen : Boolean := False;
18779
18780 function Is_Reference (N : Node_Id) return Traverse_Result;
18781 -- Determine whether node N denotes a reference to Id. If this is the
18782 -- case, set global flag Seen to True and stop the traversal.
18783
18784 ------------------
18785 -- Is_Reference --
18786 ------------------
18787
18788 function Is_Reference (N : Node_Id) return Traverse_Result is
18789 begin
18790 if Is_Entity_Name (N)
18791 and then Present (Entity (N))
18792 and then Entity (N) = Id
18793 then
18794 Seen := True;
18795 return Abandon;
18796 else
18797 return OK;
18798 end if;
18799 end Is_Reference;
18800
18801 procedure Inspect_Expression is new Traverse_Proc (Is_Reference);
18802
18803 -- Start of processing for Referenced
18804
18805 begin
18806 Inspect_Expression (Expr);
18807 return Seen;
18808 end Referenced;
18809
18810 ------------------------------------
18811 -- References_Generic_Formal_Type --
18812 ------------------------------------
18813
18814 function References_Generic_Formal_Type (N : Node_Id) return Boolean is
18815
18816 function Process (N : Node_Id) return Traverse_Result;
18817 -- Process one node in search for generic formal type
18818
18819 -------------
18820 -- Process --
18821 -------------
18822
18823 function Process (N : Node_Id) return Traverse_Result is
18824 begin
18825 if Nkind (N) in N_Has_Entity then
18826 declare
18827 E : constant Entity_Id := Entity (N);
18828 begin
18829 if Present (E) then
18830 if Is_Generic_Type (E) then
18831 return Abandon;
18832 elsif Present (Etype (E))
18833 and then Is_Generic_Type (Etype (E))
18834 then
18835 return Abandon;
18836 end if;
18837 end if;
18838 end;
18839 end if;
18840
18841 return Atree.OK;
18842 end Process;
18843
18844 function Traverse is new Traverse_Func (Process);
18845 -- Traverse tree to look for generic type
18846
18847 begin
18848 if Inside_A_Generic then
18849 return Traverse (N) = Abandon;
18850 else
18851 return False;
18852 end if;
18853 end References_Generic_Formal_Type;
18854
18855 --------------------
18856 -- Remove_Homonym --
18857 --------------------
18858
18859 procedure Remove_Homonym (E : Entity_Id) is
18860 Prev : Entity_Id := Empty;
18861 H : Entity_Id;
18862
18863 begin
18864 if E = Current_Entity (E) then
18865 if Present (Homonym (E)) then
18866 Set_Current_Entity (Homonym (E));
18867 else
18868 Set_Name_Entity_Id (Chars (E), Empty);
18869 end if;
18870
18871 else
18872 H := Current_Entity (E);
18873 while Present (H) and then H /= E loop
18874 Prev := H;
18875 H := Homonym (H);
18876 end loop;
18877
18878 -- If E is not on the homonym chain, nothing to do
18879
18880 if Present (H) then
18881 Set_Homonym (Prev, Homonym (E));
18882 end if;
18883 end if;
18884 end Remove_Homonym;
18885
18886 ------------------------------
18887 -- Remove_Overloaded_Entity --
18888 ------------------------------
18889
18890 procedure Remove_Overloaded_Entity (Id : Entity_Id) is
18891 procedure Remove_Primitive_Of (Typ : Entity_Id);
18892 -- Remove primitive subprogram Id from the list of primitives that
18893 -- belong to type Typ.
18894
18895 -------------------------
18896 -- Remove_Primitive_Of --
18897 -------------------------
18898
18899 procedure Remove_Primitive_Of (Typ : Entity_Id) is
18900 Prims : Elist_Id;
18901
18902 begin
18903 if Is_Tagged_Type (Typ) then
18904 Prims := Direct_Primitive_Operations (Typ);
18905
18906 if Present (Prims) then
18907 Remove (Prims, Id);
18908 end if;
18909 end if;
18910 end Remove_Primitive_Of;
18911
18912 -- Local variables
18913
18914 Scop : constant Entity_Id := Scope (Id);
18915 Formal : Entity_Id;
18916 Prev_Id : Entity_Id;
18917
18918 -- Start of processing for Remove_Overloaded_Entity
18919
18920 begin
18921 -- Remove the entity from the homonym chain. When the entity is the
18922 -- head of the chain, associate the entry in the name table with its
18923 -- homonym effectively making it the new head of the chain.
18924
18925 if Current_Entity (Id) = Id then
18926 Set_Name_Entity_Id (Chars (Id), Homonym (Id));
18927
18928 -- Otherwise link the previous and next homonyms
18929
18930 else
18931 Prev_Id := Current_Entity (Id);
18932 while Present (Prev_Id) and then Homonym (Prev_Id) /= Id loop
18933 Prev_Id := Homonym (Prev_Id);
18934 end loop;
18935
18936 Set_Homonym (Prev_Id, Homonym (Id));
18937 end if;
18938
18939 -- Remove the entity from the scope entity chain. When the entity is
18940 -- the head of the chain, set the next entity as the new head of the
18941 -- chain.
18942
18943 if First_Entity (Scop) = Id then
18944 Prev_Id := Empty;
18945 Set_First_Entity (Scop, Next_Entity (Id));
18946
18947 -- Otherwise the entity is either in the middle of the chain or it acts
18948 -- as its tail. Traverse and link the previous and next entities.
18949
18950 else
18951 Prev_Id := First_Entity (Scop);
18952 while Present (Prev_Id) and then Next_Entity (Prev_Id) /= Id loop
18953 Next_Entity (Prev_Id);
18954 end loop;
18955
18956 Set_Next_Entity (Prev_Id, Next_Entity (Id));
18957 end if;
18958
18959 -- Handle the case where the entity acts as the tail of the scope entity
18960 -- chain.
18961
18962 if Last_Entity (Scop) = Id then
18963 Set_Last_Entity (Scop, Prev_Id);
18964 end if;
18965
18966 -- The entity denotes a primitive subprogram. Remove it from the list of
18967 -- primitives of the associated controlling type.
18968
18969 if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then
18970 Formal := First_Formal (Id);
18971 while Present (Formal) loop
18972 if Is_Controlling_Formal (Formal) then
18973 Remove_Primitive_Of (Etype (Formal));
18974 exit;
18975 end if;
18976
18977 Next_Formal (Formal);
18978 end loop;
18979
18980 if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then
18981 Remove_Primitive_Of (Etype (Id));
18982 end if;
18983 end if;
18984 end Remove_Overloaded_Entity;
18985
18986 ---------------------
18987 -- Rep_To_Pos_Flag --
18988 ---------------------
18989
18990 function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
18991 begin
18992 return New_Occurrence_Of
18993 (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
18994 end Rep_To_Pos_Flag;
18995
18996 --------------------
18997 -- Require_Entity --
18998 --------------------
18999
19000 procedure Require_Entity (N : Node_Id) is
19001 begin
19002 if Is_Entity_Name (N) and then No (Entity (N)) then
19003 if Total_Errors_Detected /= 0 then
19004 Set_Entity (N, Any_Id);
19005 else
19006 raise Program_Error;
19007 end if;
19008 end if;
19009 end Require_Entity;
19010
19011 ------------------------------
19012 -- Requires_Transient_Scope --
19013 ------------------------------
19014
19015 -- A transient scope is required when variable-sized temporaries are
19016 -- allocated on the secondary stack, or when finalization actions must be
19017 -- generated before the next instruction.
19018
19019 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
19020 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
19021 -- ???We retain the old and new algorithms for Requires_Transient_Scope for
19022 -- the time being. New_Requires_Transient_Scope is used by default; the
19023 -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope
19024 -- instead. The intent is to use this temporarily to measure before/after
19025 -- efficiency. Note: when this temporary code is removed, the documentation
19026 -- of dQ in debug.adb should be removed.
19027
19028 procedure Results_Differ (Id : Entity_Id);
19029 -- ???Debugging code. Called when the Old_ and New_ results differ. Will be
19030 -- removed when New_Requires_Transient_Scope becomes
19031 -- Requires_Transient_Scope and Old_Requires_Transient_Scope is eliminated.
19032
19033 procedure Results_Differ (Id : Entity_Id) is
19034 begin
19035 if False then -- False to disable; True for debugging
19036 Treepr.Print_Tree_Node (Id);
19037
19038 if Old_Requires_Transient_Scope (Id) =
19039 New_Requires_Transient_Scope (Id)
19040 then
19041 raise Program_Error;
19042 end if;
19043 end if;
19044 end Results_Differ;
19045
19046 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
19047 Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id);
19048
19049 begin
19050 if Debug_Flag_QQ then
19051 return Old_Result;
19052 end if;
19053
19054 declare
19055 New_Result : constant Boolean := New_Requires_Transient_Scope (Id);
19056
19057 begin
19058 -- Assert that we're not putting things on the secondary stack if we
19059 -- didn't before; we are trying to AVOID secondary stack when
19060 -- possible.
19061
19062 if not Old_Result then
19063 pragma Assert (not New_Result);
19064 null;
19065 end if;
19066
19067 if New_Result /= Old_Result then
19068 Results_Differ (Id);
19069 end if;
19070
19071 return New_Result;
19072 end;
19073 end Requires_Transient_Scope;
19074
19075 ----------------------------------
19076 -- Old_Requires_Transient_Scope --
19077 ----------------------------------
19078
19079 function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
19080 Typ : constant Entity_Id := Underlying_Type (Id);
19081
19082 begin
19083 -- This is a private type which is not completed yet. This can only
19084 -- happen in a default expression (of a formal parameter or of a
19085 -- record component). Do not expand transient scope in this case.
19086
19087 if No (Typ) then
19088 return False;
19089
19090 -- Do not expand transient scope for non-existent procedure return
19091
19092 elsif Typ = Standard_Void_Type then
19093 return False;
19094
19095 -- Elementary types do not require a transient scope
19096
19097 elsif Is_Elementary_Type (Typ) then
19098 return False;
19099
19100 -- Generally, indefinite subtypes require a transient scope, since the
19101 -- back end cannot generate temporaries, since this is not a valid type
19102 -- for declaring an object. It might be possible to relax this in the
19103 -- future, e.g. by declaring the maximum possible space for the type.
19104
19105 elsif not Is_Definite_Subtype (Typ) then
19106 return True;
19107
19108 -- Functions returning tagged types may dispatch on result so their
19109 -- returned value is allocated on the secondary stack. Controlled
19110 -- type temporaries need finalization.
19111
19112 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
19113 return True;
19114
19115 -- Record type
19116
19117 elsif Is_Record_Type (Typ) then
19118 declare
19119 Comp : Entity_Id;
19120
19121 begin
19122 Comp := First_Entity (Typ);
19123 while Present (Comp) loop
19124 if Ekind (Comp) = E_Component then
19125
19126 -- ???It's not clear we need a full recursive call to
19127 -- Old_Requires_Transient_Scope here. Note that the
19128 -- following can't happen.
19129
19130 pragma Assert (Is_Definite_Subtype (Etype (Comp)));
19131 pragma Assert (not Has_Controlled_Component (Etype (Comp)));
19132
19133 if Old_Requires_Transient_Scope (Etype (Comp)) then
19134 return True;
19135 end if;
19136 end if;
19137
19138 Next_Entity (Comp);
19139 end loop;
19140 end;
19141
19142 return False;
19143
19144 -- String literal types never require transient scope
19145
19146 elsif Ekind (Typ) = E_String_Literal_Subtype then
19147 return False;
19148
19149 -- Array type. Note that we already know that this is a constrained
19150 -- array, since unconstrained arrays will fail the indefinite test.
19151
19152 elsif Is_Array_Type (Typ) then
19153
19154 -- If component type requires a transient scope, the array does too
19155
19156 if Old_Requires_Transient_Scope (Component_Type (Typ)) then
19157 return True;
19158
19159 -- Otherwise, we only need a transient scope if the size depends on
19160 -- the value of one or more discriminants.
19161
19162 else
19163 return Size_Depends_On_Discriminant (Typ);
19164 end if;
19165
19166 -- All other cases do not require a transient scope
19167
19168 else
19169 pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
19170 return False;
19171 end if;
19172 end Old_Requires_Transient_Scope;
19173
19174 ----------------------------------
19175 -- New_Requires_Transient_Scope --
19176 ----------------------------------
19177
19178 function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
19179
19180 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
19181 -- This is called for untagged records and protected types, with
19182 -- nondefaulted discriminants. Returns True if the size of function
19183 -- results is known at the call site, False otherwise. Returns False
19184 -- if there is a variant part that depends on the discriminants of
19185 -- this type, or if there is an array constrained by the discriminants
19186 -- of this type. ???Currently, this is overly conservative (the array
19187 -- could be nested inside some other record that is constrained by
19188 -- nondiscriminants). That is, the recursive calls are too conservative.
19189
19190 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
19191 -- Returns True if Typ is a nonlimited record with defaulted
19192 -- discriminants whose max size makes it unsuitable for allocating on
19193 -- the primary stack.
19194
19195 ------------------------------
19196 -- Caller_Known_Size_Record --
19197 ------------------------------
19198
19199 function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is
19200 pragma Assert (Typ = Underlying_Type (Typ));
19201
19202 begin
19203 if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then
19204 return False;
19205 end if;
19206
19207 declare
19208 Comp : Entity_Id;
19209
19210 begin
19211 Comp := First_Entity (Typ);
19212 while Present (Comp) loop
19213
19214 -- Only look at E_Component entities. No need to look at
19215 -- E_Discriminant entities, and we must ignore internal
19216 -- subtypes generated for constrained components.
19217
19218 if Ekind (Comp) = E_Component then
19219 declare
19220 Comp_Type : constant Entity_Id :=
19221 Underlying_Type (Etype (Comp));
19222
19223 begin
19224 if Is_Record_Type (Comp_Type)
19225 or else
19226 Is_Protected_Type (Comp_Type)
19227 then
19228 if not Caller_Known_Size_Record (Comp_Type) then
19229 return False;
19230 end if;
19231
19232 elsif Is_Array_Type (Comp_Type) then
19233 if Size_Depends_On_Discriminant (Comp_Type) then
19234 return False;
19235 end if;
19236 end if;
19237 end;
19238 end if;
19239
19240 Next_Entity (Comp);
19241 end loop;
19242 end;
19243
19244 return True;
19245 end Caller_Known_Size_Record;
19246
19247 ------------------------------
19248 -- Large_Max_Size_Mutable --
19249 ------------------------------
19250
19251 function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is
19252 pragma Assert (Typ = Underlying_Type (Typ));
19253
19254 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean;
19255 -- Returns true if the discrete type T has a large range
19256
19257 ----------------------------
19258 -- Is_Large_Discrete_Type --
19259 ----------------------------
19260
19261 function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is
19262 Threshold : constant Int := 16;
19263 -- Arbitrary threshold above which we consider it "large". We want
19264 -- a fairly large threshold, because these large types really
19265 -- shouldn't have default discriminants in the first place, in
19266 -- most cases.
19267
19268 begin
19269 return UI_To_Int (RM_Size (T)) > Threshold;
19270 end Is_Large_Discrete_Type;
19271
19272 begin
19273 if Is_Record_Type (Typ)
19274 and then not Is_Limited_View (Typ)
19275 and then Has_Defaulted_Discriminants (Typ)
19276 then
19277 -- Loop through the components, looking for an array whose upper
19278 -- bound(s) depends on discriminants, where both the subtype of
19279 -- the discriminant and the index subtype are too large.
19280
19281 declare
19282 Comp : Entity_Id;
19283
19284 begin
19285 Comp := First_Entity (Typ);
19286 while Present (Comp) loop
19287 if Ekind (Comp) = E_Component then
19288 declare
19289 Comp_Type : constant Entity_Id :=
19290 Underlying_Type (Etype (Comp));
19291 Indx : Node_Id;
19292 Ityp : Entity_Id;
19293 Hi : Node_Id;
19294
19295 begin
19296 if Is_Array_Type (Comp_Type) then
19297 Indx := First_Index (Comp_Type);
19298
19299 while Present (Indx) loop
19300 Ityp := Etype (Indx);
19301 Hi := Type_High_Bound (Ityp);
19302
19303 if Nkind (Hi) = N_Identifier
19304 and then Ekind (Entity (Hi)) = E_Discriminant
19305 and then Is_Large_Discrete_Type (Ityp)
19306 and then Is_Large_Discrete_Type
19307 (Etype (Entity (Hi)))
19308 then
19309 return True;
19310 end if;
19311
19312 Next_Index (Indx);
19313 end loop;
19314 end if;
19315 end;
19316 end if;
19317
19318 Next_Entity (Comp);
19319 end loop;
19320 end;
19321 end if;
19322
19323 return False;
19324 end Large_Max_Size_Mutable;
19325
19326 -- Local declarations
19327
19328 Typ : constant Entity_Id := Underlying_Type (Id);
19329
19330 -- Start of processing for New_Requires_Transient_Scope
19331
19332 begin
19333 -- This is a private type which is not completed yet. This can only
19334 -- happen in a default expression (of a formal parameter or of a
19335 -- record component). Do not expand transient scope in this case.
19336
19337 if No (Typ) then
19338 return False;
19339
19340 -- Do not expand transient scope for non-existent procedure return or
19341 -- string literal types.
19342
19343 elsif Typ = Standard_Void_Type
19344 or else Ekind (Typ) = E_String_Literal_Subtype
19345 then
19346 return False;
19347
19348 -- If Typ is a generic formal incomplete type, then we want to look at
19349 -- the actual type.
19350
19351 elsif Ekind (Typ) = E_Record_Subtype
19352 and then Present (Cloned_Subtype (Typ))
19353 then
19354 return New_Requires_Transient_Scope (Cloned_Subtype (Typ));
19355
19356 -- Functions returning specific tagged types may dispatch on result, so
19357 -- their returned value is allocated on the secondary stack, even in the
19358 -- definite case. We must treat nondispatching functions the same way,
19359 -- because access-to-function types can point at both, so the calling
19360 -- conventions must be compatible. Is_Tagged_Type includes controlled
19361 -- types and class-wide types. Controlled type temporaries need
19362 -- finalization.
19363
19364 -- ???It's not clear why we need to return noncontrolled types with
19365 -- controlled components on the secondary stack.
19366
19367 elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
19368 return True;
19369
19370 -- Untagged definite subtypes are known size. This includes all
19371 -- elementary [sub]types. Tasks are known size even if they have
19372 -- discriminants. So we return False here, with one exception:
19373 -- For a type like:
19374 -- type T (Last : Natural := 0) is
19375 -- X : String (1 .. Last);
19376 -- end record;
19377 -- we return True. That's because for "P(F(...));", where F returns T,
19378 -- we don't know the size of the result at the call site, so if we
19379 -- allocated it on the primary stack, we would have to allocate the
19380 -- maximum size, which is way too big.
19381
19382 elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
19383 return Large_Max_Size_Mutable (Typ);
19384
19385 -- Indefinite (discriminated) untagged record or protected type
19386
19387 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
19388 return not Caller_Known_Size_Record (Typ);
19389
19390 -- Unconstrained array
19391
19392 else
19393 pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ));
19394 return True;
19395 end if;
19396 end New_Requires_Transient_Scope;
19397
19398 --------------------------
19399 -- Reset_Analyzed_Flags --
19400 --------------------------
19401
19402 procedure Reset_Analyzed_Flags (N : Node_Id) is
19403
19404 function Clear_Analyzed (N : Node_Id) return Traverse_Result;
19405 -- Function used to reset Analyzed flags in tree. Note that we do
19406 -- not reset Analyzed flags in entities, since there is no need to
19407 -- reanalyze entities, and indeed, it is wrong to do so, since it
19408 -- can result in generating auxiliary stuff more than once.
19409
19410 --------------------
19411 -- Clear_Analyzed --
19412 --------------------
19413
19414 function Clear_Analyzed (N : Node_Id) return Traverse_Result is
19415 begin
19416 if not Has_Extension (N) then
19417 Set_Analyzed (N, False);
19418 end if;
19419
19420 return OK;
19421 end Clear_Analyzed;
19422
19423 procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
19424
19425 -- Start of processing for Reset_Analyzed_Flags
19426
19427 begin
19428 Reset_Analyzed (N);
19429 end Reset_Analyzed_Flags;
19430
19431 ------------------------
19432 -- Restore_SPARK_Mode --
19433 ------------------------
19434
19435 procedure Restore_SPARK_Mode (Mode : SPARK_Mode_Type) is
19436 begin
19437 SPARK_Mode := Mode;
19438 end Restore_SPARK_Mode;
19439
19440 --------------------------------
19441 -- Returns_Unconstrained_Type --
19442 --------------------------------
19443
19444 function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
19445 begin
19446 return Ekind (Subp) = E_Function
19447 and then not Is_Scalar_Type (Etype (Subp))
19448 and then not Is_Access_Type (Etype (Subp))
19449 and then not Is_Constrained (Etype (Subp));
19450 end Returns_Unconstrained_Type;
19451
19452 ----------------------------
19453 -- Root_Type_Of_Full_View --
19454 ----------------------------
19455
19456 function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is
19457 Rtyp : constant Entity_Id := Root_Type (T);
19458
19459 begin
19460 -- The root type of the full view may itself be a private type. Keep
19461 -- looking for the ultimate derivation parent.
19462
19463 if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then
19464 return Root_Type_Of_Full_View (Full_View (Rtyp));
19465 else
19466 return Rtyp;
19467 end if;
19468 end Root_Type_Of_Full_View;
19469
19470 ---------------------------
19471 -- Safe_To_Capture_Value --
19472 ---------------------------
19473
19474 function Safe_To_Capture_Value
19475 (N : Node_Id;
19476 Ent : Entity_Id;
19477 Cond : Boolean := False) return Boolean
19478 is
19479 begin
19480 -- The only entities for which we track constant values are variables
19481 -- which are not renamings, constants, out parameters, and in out
19482 -- parameters, so check if we have this case.
19483
19484 -- Note: it may seem odd to track constant values for constants, but in
19485 -- fact this routine is used for other purposes than simply capturing
19486 -- the value. In particular, the setting of Known[_Non]_Null.
19487
19488 if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
19489 or else
19490 Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter)
19491 then
19492 null;
19493
19494 -- For conditionals, we also allow loop parameters and all formals,
19495 -- including in parameters.
19496
19497 elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then
19498 null;
19499
19500 -- For all other cases, not just unsafe, but impossible to capture
19501 -- Current_Value, since the above are the only entities which have
19502 -- Current_Value fields.
19503
19504 else
19505 return False;
19506 end if;
19507
19508 -- Skip if volatile or aliased, since funny things might be going on in
19509 -- these cases which we cannot necessarily track. Also skip any variable
19510 -- for which an address clause is given, or whose address is taken. Also
19511 -- never capture value of library level variables (an attempt to do so
19512 -- can occur in the case of package elaboration code).
19513
19514 if Treat_As_Volatile (Ent)
19515 or else Is_Aliased (Ent)
19516 or else Present (Address_Clause (Ent))
19517 or else Address_Taken (Ent)
19518 or else (Is_Library_Level_Entity (Ent)
19519 and then Ekind (Ent) = E_Variable)
19520 then
19521 return False;
19522 end if;
19523
19524 -- OK, all above conditions are met. We also require that the scope of
19525 -- the reference be the same as the scope of the entity, not counting
19526 -- packages and blocks and loops.
19527
19528 declare
19529 E_Scope : constant Entity_Id := Scope (Ent);
19530 R_Scope : Entity_Id;
19531
19532 begin
19533 R_Scope := Current_Scope;
19534 while R_Scope /= Standard_Standard loop
19535 exit when R_Scope = E_Scope;
19536
19537 if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
19538 return False;
19539 else
19540 R_Scope := Scope (R_Scope);
19541 end if;
19542 end loop;
19543 end;
19544
19545 -- We also require that the reference does not appear in a context
19546 -- where it is not sure to be executed (i.e. a conditional context
19547 -- or an exception handler). We skip this if Cond is True, since the
19548 -- capturing of values from conditional tests handles this ok.
19549
19550 if Cond then
19551 return True;
19552 end if;
19553
19554 declare
19555 Desc : Node_Id;
19556 P : Node_Id;
19557
19558 begin
19559 Desc := N;
19560
19561 -- Seems dubious that case expressions are not handled here ???
19562
19563 P := Parent (N);
19564 while Present (P) loop
19565 if Nkind (P) = N_If_Statement
19566 or else Nkind (P) = N_Case_Statement
19567 or else (Nkind (P) in N_Short_Circuit
19568 and then Desc = Right_Opnd (P))
19569 or else (Nkind (P) = N_If_Expression
19570 and then Desc /= First (Expressions (P)))
19571 or else Nkind (P) = N_Exception_Handler
19572 or else Nkind (P) = N_Selective_Accept
19573 or else Nkind (P) = N_Conditional_Entry_Call
19574 or else Nkind (P) = N_Timed_Entry_Call
19575 or else Nkind (P) = N_Asynchronous_Select
19576 then
19577 return False;
19578
19579 else
19580 Desc := P;
19581 P := Parent (P);
19582
19583 -- A special Ada 2012 case: the original node may be part
19584 -- of the else_actions of a conditional expression, in which
19585 -- case it might not have been expanded yet, and appears in
19586 -- a non-syntactic list of actions. In that case it is clearly
19587 -- not safe to save a value.
19588
19589 if No (P)
19590 and then Is_List_Member (Desc)
19591 and then No (Parent (List_Containing (Desc)))
19592 then
19593 return False;
19594 end if;
19595 end if;
19596 end loop;
19597 end;
19598
19599 -- OK, looks safe to set value
19600
19601 return True;
19602 end Safe_To_Capture_Value;
19603
19604 ---------------
19605 -- Same_Name --
19606 ---------------
19607
19608 function Same_Name (N1, N2 : Node_Id) return Boolean is
19609 K1 : constant Node_Kind := Nkind (N1);
19610 K2 : constant Node_Kind := Nkind (N2);
19611
19612 begin
19613 if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
19614 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
19615 then
19616 return Chars (N1) = Chars (N2);
19617
19618 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
19619 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
19620 then
19621 return Same_Name (Selector_Name (N1), Selector_Name (N2))
19622 and then Same_Name (Prefix (N1), Prefix (N2));
19623
19624 else
19625 return False;
19626 end if;
19627 end Same_Name;
19628
19629 -----------------
19630 -- Same_Object --
19631 -----------------
19632
19633 function Same_Object (Node1, Node2 : Node_Id) return Boolean is
19634 N1 : constant Node_Id := Original_Node (Node1);
19635 N2 : constant Node_Id := Original_Node (Node2);
19636 -- We do the tests on original nodes, since we are most interested
19637 -- in the original source, not any expansion that got in the way.
19638
19639 K1 : constant Node_Kind := Nkind (N1);
19640 K2 : constant Node_Kind := Nkind (N2);
19641
19642 begin
19643 -- First case, both are entities with same entity
19644
19645 if K1 in N_Has_Entity and then K2 in N_Has_Entity then
19646 declare
19647 EN1 : constant Entity_Id := Entity (N1);
19648 EN2 : constant Entity_Id := Entity (N2);
19649 begin
19650 if Present (EN1) and then Present (EN2)
19651 and then (Ekind_In (EN1, E_Variable, E_Constant)
19652 or else Is_Formal (EN1))
19653 and then EN1 = EN2
19654 then
19655 return True;
19656 end if;
19657 end;
19658 end if;
19659
19660 -- Second case, selected component with same selector, same record
19661
19662 if K1 = N_Selected_Component
19663 and then K2 = N_Selected_Component
19664 and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
19665 then
19666 return Same_Object (Prefix (N1), Prefix (N2));
19667
19668 -- Third case, indexed component with same subscripts, same array
19669
19670 elsif K1 = N_Indexed_Component
19671 and then K2 = N_Indexed_Component
19672 and then Same_Object (Prefix (N1), Prefix (N2))
19673 then
19674 declare
19675 E1, E2 : Node_Id;
19676 begin
19677 E1 := First (Expressions (N1));
19678 E2 := First (Expressions (N2));
19679 while Present (E1) loop
19680 if not Same_Value (E1, E2) then
19681 return False;
19682 else
19683 Next (E1);
19684 Next (E2);
19685 end if;
19686 end loop;
19687
19688 return True;
19689 end;
19690
19691 -- Fourth case, slice of same array with same bounds
19692
19693 elsif K1 = N_Slice
19694 and then K2 = N_Slice
19695 and then Nkind (Discrete_Range (N1)) = N_Range
19696 and then Nkind (Discrete_Range (N2)) = N_Range
19697 and then Same_Value (Low_Bound (Discrete_Range (N1)),
19698 Low_Bound (Discrete_Range (N2)))
19699 and then Same_Value (High_Bound (Discrete_Range (N1)),
19700 High_Bound (Discrete_Range (N2)))
19701 then
19702 return Same_Name (Prefix (N1), Prefix (N2));
19703
19704 -- All other cases, not clearly the same object
19705
19706 else
19707 return False;
19708 end if;
19709 end Same_Object;
19710
19711 ---------------
19712 -- Same_Type --
19713 ---------------
19714
19715 function Same_Type (T1, T2 : Entity_Id) return Boolean is
19716 begin
19717 if T1 = T2 then
19718 return True;
19719
19720 elsif not Is_Constrained (T1)
19721 and then not Is_Constrained (T2)
19722 and then Base_Type (T1) = Base_Type (T2)
19723 then
19724 return True;
19725
19726 -- For now don't bother with case of identical constraints, to be
19727 -- fiddled with later on perhaps (this is only used for optimization
19728 -- purposes, so it is not critical to do a best possible job)
19729
19730 else
19731 return False;
19732 end if;
19733 end Same_Type;
19734
19735 ----------------
19736 -- Same_Value --
19737 ----------------
19738
19739 function Same_Value (Node1, Node2 : Node_Id) return Boolean is
19740 begin
19741 if Compile_Time_Known_Value (Node1)
19742 and then Compile_Time_Known_Value (Node2)
19743 and then Expr_Value (Node1) = Expr_Value (Node2)
19744 then
19745 return True;
19746 elsif Same_Object (Node1, Node2) then
19747 return True;
19748 else
19749 return False;
19750 end if;
19751 end Same_Value;
19752
19753 -----------------------------
19754 -- Save_SPARK_Mode_And_Set --
19755 -----------------------------
19756
19757 procedure Save_SPARK_Mode_And_Set
19758 (Context : Entity_Id;
19759 Mode : out SPARK_Mode_Type)
19760 is
19761 begin
19762 -- Save the current mode in effect
19763
19764 Mode := SPARK_Mode;
19765
19766 -- Do not consider illegal or partially decorated constructs
19767
19768 if Ekind (Context) = E_Void or else Error_Posted (Context) then
19769 null;
19770
19771 elsif Present (SPARK_Pragma (Context)) then
19772 SPARK_Mode := Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Context));
19773 end if;
19774 end Save_SPARK_Mode_And_Set;
19775
19776 -------------------------
19777 -- Scalar_Part_Present --
19778 -------------------------
19779
19780 function Scalar_Part_Present (T : Entity_Id) return Boolean is
19781 C : Entity_Id;
19782
19783 begin
19784 if Is_Scalar_Type (T) then
19785 return True;
19786
19787 elsif Is_Array_Type (T) then
19788 return Scalar_Part_Present (Component_Type (T));
19789
19790 elsif Is_Record_Type (T) or else Has_Discriminants (T) then
19791 C := First_Component_Or_Discriminant (T);
19792 while Present (C) loop
19793 if Scalar_Part_Present (Etype (C)) then
19794 return True;
19795 else
19796 Next_Component_Or_Discriminant (C);
19797 end if;
19798 end loop;
19799 end if;
19800
19801 return False;
19802 end Scalar_Part_Present;
19803
19804 ------------------------
19805 -- Scope_Is_Transient --
19806 ------------------------
19807
19808 function Scope_Is_Transient return Boolean is
19809 begin
19810 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
19811 end Scope_Is_Transient;
19812
19813 ------------------
19814 -- Scope_Within --
19815 ------------------
19816
19817 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
19818 Scop : Entity_Id;
19819
19820 begin
19821 Scop := Scope1;
19822 while Scop /= Standard_Standard loop
19823 Scop := Scope (Scop);
19824
19825 if Scop = Scope2 then
19826 return True;
19827 end if;
19828 end loop;
19829
19830 return False;
19831 end Scope_Within;
19832
19833 --------------------------
19834 -- Scope_Within_Or_Same --
19835 --------------------------
19836
19837 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
19838 Scop : Entity_Id;
19839
19840 begin
19841 Scop := Scope1;
19842 while Scop /= Standard_Standard loop
19843 if Scop = Scope2 then
19844 return True;
19845 else
19846 Scop := Scope (Scop);
19847 end if;
19848 end loop;
19849
19850 return False;
19851 end Scope_Within_Or_Same;
19852
19853 --------------------
19854 -- Set_Convention --
19855 --------------------
19856
19857 procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
19858 begin
19859 Basic_Set_Convention (E, Val);
19860
19861 if Is_Type (E)
19862 and then Is_Access_Subprogram_Type (Base_Type (E))
19863 and then Has_Foreign_Convention (E)
19864 then
19865
19866 -- A pragma Convention in an instance may apply to the subtype
19867 -- created for a formal, in which case we have already verified
19868 -- that conventions of actual and formal match and there is nothing
19869 -- to flag on the subtype.
19870
19871 if In_Instance then
19872 null;
19873 else
19874 Set_Can_Use_Internal_Rep (E, False);
19875 end if;
19876 end if;
19877
19878 -- If E is an object or component, and the type of E is an anonymous
19879 -- access type with no convention set, then also set the convention of
19880 -- the anonymous access type. We do not do this for anonymous protected
19881 -- types, since protected types always have the default convention.
19882
19883 if Present (Etype (E))
19884 and then (Is_Object (E)
19885 or else Ekind (E) = E_Component
19886
19887 -- Allow E_Void (happens for pragma Convention appearing
19888 -- in the middle of a record applying to a component)
19889
19890 or else Ekind (E) = E_Void)
19891 then
19892 declare
19893 Typ : constant Entity_Id := Etype (E);
19894
19895 begin
19896 if Ekind_In (Typ, E_Anonymous_Access_Type,
19897 E_Anonymous_Access_Subprogram_Type)
19898 and then not Has_Convention_Pragma (Typ)
19899 then
19900 Basic_Set_Convention (Typ, Val);
19901 Set_Has_Convention_Pragma (Typ);
19902
19903 -- And for the access subprogram type, deal similarly with the
19904 -- designated E_Subprogram_Type if it is also internal (which
19905 -- it always is?)
19906
19907 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
19908 declare
19909 Dtype : constant Entity_Id := Designated_Type (Typ);
19910 begin
19911 if Ekind (Dtype) = E_Subprogram_Type
19912 and then Is_Itype (Dtype)
19913 and then not Has_Convention_Pragma (Dtype)
19914 then
19915 Basic_Set_Convention (Dtype, Val);
19916 Set_Has_Convention_Pragma (Dtype);
19917 end if;
19918 end;
19919 end if;
19920 end if;
19921 end;
19922 end if;
19923 end Set_Convention;
19924
19925 ------------------------
19926 -- Set_Current_Entity --
19927 ------------------------
19928
19929 -- The given entity is to be set as the currently visible definition of its
19930 -- associated name (i.e. the Node_Id associated with its name). All we have
19931 -- to do is to get the name from the identifier, and then set the
19932 -- associated Node_Id to point to the given entity.
19933
19934 procedure Set_Current_Entity (E : Entity_Id) is
19935 begin
19936 Set_Name_Entity_Id (Chars (E), E);
19937 end Set_Current_Entity;
19938
19939 ---------------------------
19940 -- Set_Debug_Info_Needed --
19941 ---------------------------
19942
19943 procedure Set_Debug_Info_Needed (T : Entity_Id) is
19944
19945 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
19946 pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
19947 -- Used to set debug info in a related node if not set already
19948
19949 --------------------------------------
19950 -- Set_Debug_Info_Needed_If_Not_Set --
19951 --------------------------------------
19952
19953 procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
19954 begin
19955 if Present (E) and then not Needs_Debug_Info (E) then
19956 Set_Debug_Info_Needed (E);
19957
19958 -- For a private type, indicate that the full view also needs
19959 -- debug information.
19960
19961 if Is_Type (E)
19962 and then Is_Private_Type (E)
19963 and then Present (Full_View (E))
19964 then
19965 Set_Debug_Info_Needed (Full_View (E));
19966 end if;
19967 end if;
19968 end Set_Debug_Info_Needed_If_Not_Set;
19969
19970 -- Start of processing for Set_Debug_Info_Needed
19971
19972 begin
19973 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which
19974 -- indicates that Debug_Info_Needed is never required for the entity.
19975 -- Nothing to do if entity comes from a predefined file. Library files
19976 -- are compiled without debug information, but inlined bodies of these
19977 -- routines may appear in user code, and debug information on them ends
19978 -- up complicating debugging the user code.
19979
19980 if No (T)
19981 or else Debug_Info_Off (T)
19982 then
19983 return;
19984
19985 elsif In_Inlined_Body
19986 and then Is_Predefined_File_Name
19987 (Unit_File_Name (Get_Source_Unit (Sloc (T))))
19988 then
19989 Set_Needs_Debug_Info (T, False);
19990 end if;
19991
19992 -- Set flag in entity itself. Note that we will go through the following
19993 -- circuitry even if the flag is already set on T. That's intentional,
19994 -- it makes sure that the flag will be set in subsidiary entities.
19995
19996 Set_Needs_Debug_Info (T);
19997
19998 -- Set flag on subsidiary entities if not set already
19999
20000 if Is_Object (T) then
20001 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
20002
20003 elsif Is_Type (T) then
20004 Set_Debug_Info_Needed_If_Not_Set (Etype (T));
20005
20006 if Is_Record_Type (T) then
20007 declare
20008 Ent : Entity_Id := First_Entity (T);
20009 begin
20010 while Present (Ent) loop
20011 Set_Debug_Info_Needed_If_Not_Set (Ent);
20012 Next_Entity (Ent);
20013 end loop;
20014 end;
20015
20016 -- For a class wide subtype, we also need debug information
20017 -- for the equivalent type.
20018
20019 if Ekind (T) = E_Class_Wide_Subtype then
20020 Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
20021 end if;
20022
20023 elsif Is_Array_Type (T) then
20024 Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
20025
20026 declare
20027 Indx : Node_Id := First_Index (T);
20028 begin
20029 while Present (Indx) loop
20030 Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
20031 Indx := Next_Index (Indx);
20032 end loop;
20033 end;
20034
20035 -- For a packed array type, we also need debug information for
20036 -- the type used to represent the packed array. Conversely, we
20037 -- also need it for the former if we need it for the latter.
20038
20039 if Is_Packed (T) then
20040 Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T));
20041 end if;
20042
20043 if Is_Packed_Array_Impl_Type (T) then
20044 Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T));
20045 end if;
20046
20047 elsif Is_Access_Type (T) then
20048 Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
20049
20050 elsif Is_Private_Type (T) then
20051 declare
20052 FV : constant Entity_Id := Full_View (T);
20053
20054 begin
20055 Set_Debug_Info_Needed_If_Not_Set (FV);
20056
20057 -- If the full view is itself a derived private type, we need
20058 -- debug information on its underlying type.
20059
20060 if Present (FV)
20061 and then Is_Private_Type (FV)
20062 and then Present (Underlying_Full_View (FV))
20063 then
20064 Set_Needs_Debug_Info (Underlying_Full_View (FV));
20065 end if;
20066 end;
20067
20068 elsif Is_Protected_Type (T) then
20069 Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
20070
20071 elsif Is_Scalar_Type (T) then
20072
20073 -- If the subrange bounds are materialized by dedicated constant
20074 -- objects, also include them in the debug info to make sure the
20075 -- debugger can properly use them.
20076
20077 if Present (Scalar_Range (T))
20078 and then Nkind (Scalar_Range (T)) = N_Range
20079 then
20080 declare
20081 Low_Bnd : constant Node_Id := Type_Low_Bound (T);
20082 High_Bnd : constant Node_Id := Type_High_Bound (T);
20083
20084 begin
20085 if Is_Entity_Name (Low_Bnd) then
20086 Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd));
20087 end if;
20088
20089 if Is_Entity_Name (High_Bnd) then
20090 Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd));
20091 end if;
20092 end;
20093 end if;
20094 end if;
20095 end if;
20096 end Set_Debug_Info_Needed;
20097
20098 ----------------------------
20099 -- Set_Entity_With_Checks --
20100 ----------------------------
20101
20102 procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is
20103 Val_Actual : Entity_Id;
20104 Nod : Node_Id;
20105 Post_Node : Node_Id;
20106
20107 begin
20108 -- Unconditionally set the entity
20109
20110 Set_Entity (N, Val);
20111
20112 -- The node to post on is the selector in the case of an expanded name,
20113 -- and otherwise the node itself.
20114
20115 if Nkind (N) = N_Expanded_Name then
20116 Post_Node := Selector_Name (N);
20117 else
20118 Post_Node := N;
20119 end if;
20120
20121 -- Check for violation of No_Fixed_IO
20122
20123 if Restriction_Check_Required (No_Fixed_IO)
20124 and then
20125 ((RTU_Loaded (Ada_Text_IO)
20126 and then (Is_RTE (Val, RE_Decimal_IO)
20127 or else
20128 Is_RTE (Val, RE_Fixed_IO)))
20129
20130 or else
20131 (RTU_Loaded (Ada_Wide_Text_IO)
20132 and then (Is_RTE (Val, RO_WT_Decimal_IO)
20133 or else
20134 Is_RTE (Val, RO_WT_Fixed_IO)))
20135
20136 or else
20137 (RTU_Loaded (Ada_Wide_Wide_Text_IO)
20138 and then (Is_RTE (Val, RO_WW_Decimal_IO)
20139 or else
20140 Is_RTE (Val, RO_WW_Fixed_IO))))
20141
20142 -- A special extra check, don't complain about a reference from within
20143 -- the Ada.Interrupts package itself!
20144
20145 and then not In_Same_Extended_Unit (N, Val)
20146 then
20147 Check_Restriction (No_Fixed_IO, Post_Node);
20148 end if;
20149
20150 -- Remaining checks are only done on source nodes. Note that we test
20151 -- for violation of No_Fixed_IO even on non-source nodes, because the
20152 -- cases for checking violations of this restriction are instantiations
20153 -- where the reference in the instance has Comes_From_Source False.
20154
20155 if not Comes_From_Source (N) then
20156 return;
20157 end if;
20158
20159 -- Check for violation of No_Abort_Statements, which is triggered by
20160 -- call to Ada.Task_Identification.Abort_Task.
20161
20162 if Restriction_Check_Required (No_Abort_Statements)
20163 and then (Is_RTE (Val, RE_Abort_Task))
20164
20165 -- A special extra check, don't complain about a reference from within
20166 -- the Ada.Task_Identification package itself!
20167
20168 and then not In_Same_Extended_Unit (N, Val)
20169 then
20170 Check_Restriction (No_Abort_Statements, Post_Node);
20171 end if;
20172
20173 if Val = Standard_Long_Long_Integer then
20174 Check_Restriction (No_Long_Long_Integers, Post_Node);
20175 end if;
20176
20177 -- Check for violation of No_Dynamic_Attachment
20178
20179 if Restriction_Check_Required (No_Dynamic_Attachment)
20180 and then RTU_Loaded (Ada_Interrupts)
20181 and then (Is_RTE (Val, RE_Is_Reserved) or else
20182 Is_RTE (Val, RE_Is_Attached) or else
20183 Is_RTE (Val, RE_Current_Handler) or else
20184 Is_RTE (Val, RE_Attach_Handler) or else
20185 Is_RTE (Val, RE_Exchange_Handler) or else
20186 Is_RTE (Val, RE_Detach_Handler) or else
20187 Is_RTE (Val, RE_Reference))
20188
20189 -- A special extra check, don't complain about a reference from within
20190 -- the Ada.Interrupts package itself!
20191
20192 and then not In_Same_Extended_Unit (N, Val)
20193 then
20194 Check_Restriction (No_Dynamic_Attachment, Post_Node);
20195 end if;
20196
20197 -- Check for No_Implementation_Identifiers
20198
20199 if Restriction_Check_Required (No_Implementation_Identifiers) then
20200
20201 -- We have an implementation defined entity if it is marked as
20202 -- implementation defined, or is defined in a package marked as
20203 -- implementation defined. However, library packages themselves
20204 -- are excluded (we don't want to flag Interfaces itself, just
20205 -- the entities within it).
20206
20207 if (Is_Implementation_Defined (Val)
20208 or else
20209 (Present (Scope (Val))
20210 and then Is_Implementation_Defined (Scope (Val))))
20211 and then not (Ekind_In (Val, E_Package, E_Generic_Package)
20212 and then Is_Library_Level_Entity (Val))
20213 then
20214 Check_Restriction (No_Implementation_Identifiers, Post_Node);
20215 end if;
20216 end if;
20217
20218 -- Do the style check
20219
20220 if Style_Check
20221 and then not Suppress_Style_Checks (Val)
20222 and then not In_Instance
20223 then
20224 if Nkind (N) = N_Identifier then
20225 Nod := N;
20226 elsif Nkind (N) = N_Expanded_Name then
20227 Nod := Selector_Name (N);
20228 else
20229 return;
20230 end if;
20231
20232 -- A special situation arises for derived operations, where we want
20233 -- to do the check against the parent (since the Sloc of the derived
20234 -- operation points to the derived type declaration itself).
20235
20236 Val_Actual := Val;
20237 while not Comes_From_Source (Val_Actual)
20238 and then Nkind (Val_Actual) in N_Entity
20239 and then (Ekind (Val_Actual) = E_Enumeration_Literal
20240 or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual))
20241 and then Present (Alias (Val_Actual))
20242 loop
20243 Val_Actual := Alias (Val_Actual);
20244 end loop;
20245
20246 -- Renaming declarations for generic actuals do not come from source,
20247 -- and have a different name from that of the entity they rename, so
20248 -- there is no style check to perform here.
20249
20250 if Chars (Nod) = Chars (Val_Actual) then
20251 Style.Check_Identifier (Nod, Val_Actual);
20252 end if;
20253 end if;
20254
20255 Set_Entity (N, Val);
20256 end Set_Entity_With_Checks;
20257
20258 ------------------------
20259 -- Set_Name_Entity_Id --
20260 ------------------------
20261
20262 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
20263 begin
20264 Set_Name_Table_Int (Id, Int (Val));
20265 end Set_Name_Entity_Id;
20266
20267 ---------------------
20268 -- Set_Next_Actual --
20269 ---------------------
20270
20271 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
20272 begin
20273 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
20274 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
20275 end if;
20276 end Set_Next_Actual;
20277
20278 ----------------------------------
20279 -- Set_Optimize_Alignment_Flags --
20280 ----------------------------------
20281
20282 procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
20283 begin
20284 if Optimize_Alignment = 'S' then
20285 Set_Optimize_Alignment_Space (E);
20286 elsif Optimize_Alignment = 'T' then
20287 Set_Optimize_Alignment_Time (E);
20288 end if;
20289 end Set_Optimize_Alignment_Flags;
20290
20291 -----------------------
20292 -- Set_Public_Status --
20293 -----------------------
20294
20295 procedure Set_Public_Status (Id : Entity_Id) is
20296 S : constant Entity_Id := Current_Scope;
20297
20298 function Within_HSS_Or_If (E : Entity_Id) return Boolean;
20299 -- Determines if E is defined within handled statement sequence or
20300 -- an if statement, returns True if so, False otherwise.
20301
20302 ----------------------
20303 -- Within_HSS_Or_If --
20304 ----------------------
20305
20306 function Within_HSS_Or_If (E : Entity_Id) return Boolean is
20307 N : Node_Id;
20308 begin
20309 N := Declaration_Node (E);
20310 loop
20311 N := Parent (N);
20312
20313 if No (N) then
20314 return False;
20315
20316 elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
20317 N_If_Statement)
20318 then
20319 return True;
20320 end if;
20321 end loop;
20322 end Within_HSS_Or_If;
20323
20324 -- Start of processing for Set_Public_Status
20325
20326 begin
20327 -- Everything in the scope of Standard is public
20328
20329 if S = Standard_Standard then
20330 Set_Is_Public (Id);
20331
20332 -- Entity is definitely not public if enclosing scope is not public
20333
20334 elsif not Is_Public (S) then
20335 return;
20336
20337 -- An object or function declaration that occurs in a handled sequence
20338 -- of statements or within an if statement is the declaration for a
20339 -- temporary object or local subprogram generated by the expander. It
20340 -- never needs to be made public and furthermore, making it public can
20341 -- cause back end problems.
20342
20343 elsif Nkind_In (Parent (Id), N_Object_Declaration,
20344 N_Function_Specification)
20345 and then Within_HSS_Or_If (Id)
20346 then
20347 return;
20348
20349 -- Entities in public packages or records are public
20350
20351 elsif Ekind (S) = E_Package or Is_Record_Type (S) then
20352 Set_Is_Public (Id);
20353
20354 -- The bounds of an entry family declaration can generate object
20355 -- declarations that are visible to the back-end, e.g. in the
20356 -- the declaration of a composite type that contains tasks.
20357
20358 elsif Is_Concurrent_Type (S)
20359 and then not Has_Completion (S)
20360 and then Nkind (Parent (Id)) = N_Object_Declaration
20361 then
20362 Set_Is_Public (Id);
20363 end if;
20364 end Set_Public_Status;
20365
20366 -----------------------------
20367 -- Set_Referenced_Modified --
20368 -----------------------------
20369
20370 procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
20371 Pref : Node_Id;
20372
20373 begin
20374 -- Deal with indexed or selected component where prefix is modified
20375
20376 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
20377 Pref := Prefix (N);
20378
20379 -- If prefix is access type, then it is the designated object that is
20380 -- being modified, which means we have no entity to set the flag on.
20381
20382 if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
20383 return;
20384
20385 -- Otherwise chase the prefix
20386
20387 else
20388 Set_Referenced_Modified (Pref, Out_Param);
20389 end if;
20390
20391 -- Otherwise see if we have an entity name (only other case to process)
20392
20393 elsif Is_Entity_Name (N) and then Present (Entity (N)) then
20394 Set_Referenced_As_LHS (Entity (N), not Out_Param);
20395 Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
20396 end if;
20397 end Set_Referenced_Modified;
20398
20399 ----------------------------
20400 -- Set_Scope_Is_Transient --
20401 ----------------------------
20402
20403 procedure Set_Scope_Is_Transient (V : Boolean := True) is
20404 begin
20405 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
20406 end Set_Scope_Is_Transient;
20407
20408 -------------------
20409 -- Set_Size_Info --
20410 -------------------
20411
20412 procedure Set_Size_Info (T1, T2 : Entity_Id) is
20413 begin
20414 -- We copy Esize, but not RM_Size, since in general RM_Size is
20415 -- subtype specific and does not get inherited by all subtypes.
20416
20417 Set_Esize (T1, Esize (T2));
20418 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
20419
20420 if Is_Discrete_Or_Fixed_Point_Type (T1)
20421 and then
20422 Is_Discrete_Or_Fixed_Point_Type (T2)
20423 then
20424 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
20425 end if;
20426
20427 Set_Alignment (T1, Alignment (T2));
20428 end Set_Size_Info;
20429
20430 --------------------
20431 -- Static_Boolean --
20432 --------------------
20433
20434 function Static_Boolean (N : Node_Id) return Uint is
20435 begin
20436 Analyze_And_Resolve (N, Standard_Boolean);
20437
20438 if N = Error
20439 or else Error_Posted (N)
20440 or else Etype (N) = Any_Type
20441 then
20442 return No_Uint;
20443 end if;
20444
20445 if Is_OK_Static_Expression (N) then
20446 if not Raises_Constraint_Error (N) then
20447 return Expr_Value (N);
20448 else
20449 return No_Uint;
20450 end if;
20451
20452 elsif Etype (N) = Any_Type then
20453 return No_Uint;
20454
20455 else
20456 Flag_Non_Static_Expr
20457 ("static boolean expression required here", N);
20458 return No_Uint;
20459 end if;
20460 end Static_Boolean;
20461
20462 --------------------
20463 -- Static_Integer --
20464 --------------------
20465
20466 function Static_Integer (N : Node_Id) return Uint is
20467 begin
20468 Analyze_And_Resolve (N, Any_Integer);
20469
20470 if N = Error
20471 or else Error_Posted (N)
20472 or else Etype (N) = Any_Type
20473 then
20474 return No_Uint;
20475 end if;
20476
20477 if Is_OK_Static_Expression (N) then
20478 if not Raises_Constraint_Error (N) then
20479 return Expr_Value (N);
20480 else
20481 return No_Uint;
20482 end if;
20483
20484 elsif Etype (N) = Any_Type then
20485 return No_Uint;
20486
20487 else
20488 Flag_Non_Static_Expr
20489 ("static integer expression required here", N);
20490 return No_Uint;
20491 end if;
20492 end Static_Integer;
20493
20494 --------------------------
20495 -- Statically_Different --
20496 --------------------------
20497
20498 function Statically_Different (E1, E2 : Node_Id) return Boolean is
20499 R1 : constant Node_Id := Get_Referenced_Object (E1);
20500 R2 : constant Node_Id := Get_Referenced_Object (E2);
20501 begin
20502 return Is_Entity_Name (R1)
20503 and then Is_Entity_Name (R2)
20504 and then Entity (R1) /= Entity (R2)
20505 and then not Is_Formal (Entity (R1))
20506 and then not Is_Formal (Entity (R2));
20507 end Statically_Different;
20508
20509 --------------------------------------
20510 -- Subject_To_Loop_Entry_Attributes --
20511 --------------------------------------
20512
20513 function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is
20514 Stmt : Node_Id;
20515
20516 begin
20517 Stmt := N;
20518
20519 -- The expansion mechanism transform a loop subject to at least one
20520 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
20521 -- the conditional part.
20522
20523 if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
20524 and then Nkind (Original_Node (N)) = N_Loop_Statement
20525 then
20526 Stmt := Original_Node (N);
20527 end if;
20528
20529 return
20530 Nkind (Stmt) = N_Loop_Statement
20531 and then Present (Identifier (Stmt))
20532 and then Present (Entity (Identifier (Stmt)))
20533 and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
20534 end Subject_To_Loop_Entry_Attributes;
20535
20536 -----------------------------
20537 -- Subprogram_Access_Level --
20538 -----------------------------
20539
20540 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
20541 begin
20542 if Present (Alias (Subp)) then
20543 return Subprogram_Access_Level (Alias (Subp));
20544 else
20545 return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
20546 end if;
20547 end Subprogram_Access_Level;
20548
20549 -------------------------------
20550 -- Support_Atomic_Primitives --
20551 -------------------------------
20552
20553 function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is
20554 Size : Int;
20555
20556 begin
20557 -- Verify the alignment of Typ is known
20558
20559 if not Known_Alignment (Typ) then
20560 return False;
20561 end if;
20562
20563 if Known_Static_Esize (Typ) then
20564 Size := UI_To_Int (Esize (Typ));
20565
20566 -- If the Esize (Object_Size) is unknown at compile time, look at the
20567 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
20568
20569 elsif Known_Static_RM_Size (Typ) then
20570 Size := UI_To_Int (RM_Size (Typ));
20571
20572 -- Otherwise, the size is considered to be unknown.
20573
20574 else
20575 return False;
20576 end if;
20577
20578 -- Check that the size of the component is 8, 16, 32, or 64 bits and
20579 -- that Typ is properly aligned.
20580
20581 case Size is
20582 when 8 | 16 | 32 | 64 =>
20583 return Size = UI_To_Int (Alignment (Typ)) * 8;
20584 when others =>
20585 return False;
20586 end case;
20587 end Support_Atomic_Primitives;
20588
20589 -----------------
20590 -- Trace_Scope --
20591 -----------------
20592
20593 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
20594 begin
20595 if Debug_Flag_W then
20596 for J in 0 .. Scope_Stack.Last loop
20597 Write_Str (" ");
20598 end loop;
20599
20600 Write_Str (Msg);
20601 Write_Name (Chars (E));
20602 Write_Str (" from ");
20603 Write_Location (Sloc (N));
20604 Write_Eol;
20605 end if;
20606 end Trace_Scope;
20607
20608 -----------------------
20609 -- Transfer_Entities --
20610 -----------------------
20611
20612 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
20613 procedure Set_Public_Status_Of (Id : Entity_Id);
20614 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
20615 -- Set_Public_Status. If successfull and Id denotes a record type, set
20616 -- the Is_Public attribute of its fields.
20617
20618 --------------------------
20619 -- Set_Public_Status_Of --
20620 --------------------------
20621
20622 procedure Set_Public_Status_Of (Id : Entity_Id) is
20623 Field : Entity_Id;
20624
20625 begin
20626 if not Is_Public (Id) then
20627 Set_Public_Status (Id);
20628
20629 -- When the input entity is a public record type, ensure that all
20630 -- its internal fields are also exposed to the linker. The fields
20631 -- of a class-wide type are never made public.
20632
20633 if Is_Public (Id)
20634 and then Is_Record_Type (Id)
20635 and then not Is_Class_Wide_Type (Id)
20636 then
20637 Field := First_Entity (Id);
20638 while Present (Field) loop
20639 Set_Is_Public (Field);
20640 Next_Entity (Field);
20641 end loop;
20642 end if;
20643 end if;
20644 end Set_Public_Status_Of;
20645
20646 -- Local variables
20647
20648 Full_Id : Entity_Id;
20649 Id : Entity_Id;
20650
20651 -- Start of processing for Transfer_Entities
20652
20653 begin
20654 Id := First_Entity (From);
20655
20656 if Present (Id) then
20657
20658 -- Merge the entity chain of the source scope with that of the
20659 -- destination scope.
20660
20661 if Present (Last_Entity (To)) then
20662 Set_Next_Entity (Last_Entity (To), Id);
20663 else
20664 Set_First_Entity (To, Id);
20665 end if;
20666
20667 Set_Last_Entity (To, Last_Entity (From));
20668
20669 -- Inspect the entities of the source scope and update their Scope
20670 -- attribute.
20671
20672 while Present (Id) loop
20673 Set_Scope (Id, To);
20674 Set_Public_Status_Of (Id);
20675
20676 -- Handle an internally generated full view for a private type
20677
20678 if Is_Private_Type (Id)
20679 and then Present (Full_View (Id))
20680 and then Is_Itype (Full_View (Id))
20681 then
20682 Full_Id := Full_View (Id);
20683
20684 Set_Scope (Full_Id, To);
20685 Set_Public_Status_Of (Full_Id);
20686 end if;
20687
20688 Next_Entity (Id);
20689 end loop;
20690
20691 Set_First_Entity (From, Empty);
20692 Set_Last_Entity (From, Empty);
20693 end if;
20694 end Transfer_Entities;
20695
20696 -----------------------
20697 -- Type_Access_Level --
20698 -----------------------
20699
20700 function Type_Access_Level (Typ : Entity_Id) return Uint is
20701 Btyp : Entity_Id;
20702
20703 begin
20704 Btyp := Base_Type (Typ);
20705
20706 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
20707 -- simply use the level where the type is declared. This is true for
20708 -- stand-alone object declarations, and for anonymous access types
20709 -- associated with components the level is the same as that of the
20710 -- enclosing composite type. However, special treatment is needed for
20711 -- the cases of access parameters, return objects of an anonymous access
20712 -- type, and, in Ada 95, access discriminants of limited types.
20713
20714 if Is_Access_Type (Btyp) then
20715 if Ekind (Btyp) = E_Anonymous_Access_Type then
20716
20717 -- If the type is a nonlocal anonymous access type (such as for
20718 -- an access parameter) we treat it as being declared at the
20719 -- library level to ensure that names such as X.all'access don't
20720 -- fail static accessibility checks.
20721
20722 if not Is_Local_Anonymous_Access (Typ) then
20723 return Scope_Depth (Standard_Standard);
20724
20725 -- If this is a return object, the accessibility level is that of
20726 -- the result subtype of the enclosing function. The test here is
20727 -- little complicated, because we have to account for extended
20728 -- return statements that have been rewritten as blocks, in which
20729 -- case we have to find and the Is_Return_Object attribute of the
20730 -- itype's associated object. It would be nice to find a way to
20731 -- simplify this test, but it doesn't seem worthwhile to add a new
20732 -- flag just for purposes of this test. ???
20733
20734 elsif Ekind (Scope (Btyp)) = E_Return_Statement
20735 or else
20736 (Is_Itype (Btyp)
20737 and then Nkind (Associated_Node_For_Itype (Btyp)) =
20738 N_Object_Declaration
20739 and then Is_Return_Object
20740 (Defining_Identifier
20741 (Associated_Node_For_Itype (Btyp))))
20742 then
20743 declare
20744 Scop : Entity_Id;
20745
20746 begin
20747 Scop := Scope (Scope (Btyp));
20748 while Present (Scop) loop
20749 exit when Ekind (Scop) = E_Function;
20750 Scop := Scope (Scop);
20751 end loop;
20752
20753 -- Treat the return object's type as having the level of the
20754 -- function's result subtype (as per RM05-6.5(5.3/2)).
20755
20756 return Type_Access_Level (Etype (Scop));
20757 end;
20758 end if;
20759 end if;
20760
20761 Btyp := Root_Type (Btyp);
20762
20763 -- The accessibility level of anonymous access types associated with
20764 -- discriminants is that of the current instance of the type, and
20765 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
20766
20767 -- AI-402: access discriminants have accessibility based on the
20768 -- object rather than the type in Ada 2005, so the above paragraph
20769 -- doesn't apply.
20770
20771 -- ??? Needs completion with rules from AI-416
20772
20773 if Ada_Version <= Ada_95
20774 and then Ekind (Typ) = E_Anonymous_Access_Type
20775 and then Present (Associated_Node_For_Itype (Typ))
20776 and then Nkind (Associated_Node_For_Itype (Typ)) =
20777 N_Discriminant_Specification
20778 then
20779 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
20780 end if;
20781 end if;
20782
20783 -- Return library level for a generic formal type. This is done because
20784 -- RM(10.3.2) says that "The statically deeper relationship does not
20785 -- apply to ... a descendant of a generic formal type". Rather than
20786 -- checking at each point where a static accessibility check is
20787 -- performed to see if we are dealing with a formal type, this rule is
20788 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
20789 -- return extreme values for a formal type; Deepest_Type_Access_Level
20790 -- returns Int'Last. By calling the appropriate function from among the
20791 -- two, we ensure that the static accessibility check will pass if we
20792 -- happen to run into a formal type. More specifically, we should call
20793 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
20794 -- call occurs as part of a static accessibility check and the error
20795 -- case is the case where the type's level is too shallow (as opposed
20796 -- to too deep).
20797
20798 if Is_Generic_Type (Root_Type (Btyp)) then
20799 return Scope_Depth (Standard_Standard);
20800 end if;
20801
20802 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
20803 end Type_Access_Level;
20804
20805 ------------------------------------
20806 -- Type_Without_Stream_Operation --
20807 ------------------------------------
20808
20809 function Type_Without_Stream_Operation
20810 (T : Entity_Id;
20811 Op : TSS_Name_Type := TSS_Null) return Entity_Id
20812 is
20813 BT : constant Entity_Id := Base_Type (T);
20814 Op_Missing : Boolean;
20815
20816 begin
20817 if not Restriction_Active (No_Default_Stream_Attributes) then
20818 return Empty;
20819 end if;
20820
20821 if Is_Elementary_Type (T) then
20822 if Op = TSS_Null then
20823 Op_Missing :=
20824 No (TSS (BT, TSS_Stream_Read))
20825 or else No (TSS (BT, TSS_Stream_Write));
20826
20827 else
20828 Op_Missing := No (TSS (BT, Op));
20829 end if;
20830
20831 if Op_Missing then
20832 return T;
20833 else
20834 return Empty;
20835 end if;
20836
20837 elsif Is_Array_Type (T) then
20838 return Type_Without_Stream_Operation (Component_Type (T), Op);
20839
20840 elsif Is_Record_Type (T) then
20841 declare
20842 Comp : Entity_Id;
20843 C_Typ : Entity_Id;
20844
20845 begin
20846 Comp := First_Component (T);
20847 while Present (Comp) loop
20848 C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
20849
20850 if Present (C_Typ) then
20851 return C_Typ;
20852 end if;
20853
20854 Next_Component (Comp);
20855 end loop;
20856
20857 return Empty;
20858 end;
20859
20860 elsif Is_Private_Type (T) and then Present (Full_View (T)) then
20861 return Type_Without_Stream_Operation (Full_View (T), Op);
20862 else
20863 return Empty;
20864 end if;
20865 end Type_Without_Stream_Operation;
20866
20867 ----------------------------
20868 -- Unique_Defining_Entity --
20869 ----------------------------
20870
20871 function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
20872 begin
20873 return Unique_Entity (Defining_Entity (N));
20874 end Unique_Defining_Entity;
20875
20876 -------------------
20877 -- Unique_Entity --
20878 -------------------
20879
20880 function Unique_Entity (E : Entity_Id) return Entity_Id is
20881 U : Entity_Id := E;
20882 P : Node_Id;
20883
20884 begin
20885 case Ekind (E) is
20886 when E_Constant =>
20887 if Present (Full_View (E)) then
20888 U := Full_View (E);
20889 end if;
20890
20891 when Entry_Kind =>
20892 if Nkind (Parent (E)) = N_Entry_Body then
20893 declare
20894 Prot_Item : Entity_Id;
20895 begin
20896 -- Traverse the entity list of the protected type and locate
20897 -- an entry declaration which matches the entry body.
20898
20899 Prot_Item := First_Entity (Scope (E));
20900 while Present (Prot_Item) loop
20901 if Ekind (Prot_Item) = E_Entry
20902 and then Corresponding_Body (Parent (Prot_Item)) = E
20903 then
20904 U := Prot_Item;
20905 exit;
20906 end if;
20907
20908 Next_Entity (Prot_Item);
20909 end loop;
20910 end;
20911 end if;
20912
20913 when Formal_Kind =>
20914 if Present (Spec_Entity (E)) then
20915 U := Spec_Entity (E);
20916 end if;
20917
20918 when E_Package_Body =>
20919 P := Parent (E);
20920
20921 if Nkind (P) = N_Defining_Program_Unit_Name then
20922 P := Parent (P);
20923 end if;
20924
20925 if Nkind (P) = N_Package_Body
20926 and then Present (Corresponding_Spec (P))
20927 then
20928 U := Corresponding_Spec (P);
20929
20930 elsif Nkind (P) = N_Package_Body_Stub
20931 and then Present (Corresponding_Spec_Of_Stub (P))
20932 then
20933 U := Corresponding_Spec_Of_Stub (P);
20934 end if;
20935
20936 when E_Protected_Body =>
20937 P := Parent (E);
20938
20939 if Nkind (P) = N_Protected_Body
20940 and then Present (Corresponding_Spec (P))
20941 then
20942 U := Corresponding_Spec (P);
20943
20944 elsif Nkind (P) = N_Protected_Body_Stub
20945 and then Present (Corresponding_Spec_Of_Stub (P))
20946 then
20947 U := Corresponding_Spec_Of_Stub (P);
20948 end if;
20949
20950 when E_Subprogram_Body =>
20951 P := Parent (E);
20952
20953 if Nkind (P) = N_Defining_Program_Unit_Name then
20954 P := Parent (P);
20955 end if;
20956
20957 P := Parent (P);
20958
20959 if Nkind (P) = N_Subprogram_Body
20960 and then Present (Corresponding_Spec (P))
20961 then
20962 U := Corresponding_Spec (P);
20963
20964 elsif Nkind (P) = N_Subprogram_Body_Stub
20965 and then Present (Corresponding_Spec_Of_Stub (P))
20966 then
20967 U := Corresponding_Spec_Of_Stub (P);
20968
20969 elsif Nkind (P) = N_Subprogram_Renaming_Declaration then
20970 U := Corresponding_Spec (P);
20971 end if;
20972
20973 when E_Task_Body =>
20974 P := Parent (E);
20975
20976 if Nkind (P) = N_Task_Body
20977 and then Present (Corresponding_Spec (P))
20978 then
20979 U := Corresponding_Spec (P);
20980
20981 elsif Nkind (P) = N_Task_Body_Stub
20982 and then Present (Corresponding_Spec_Of_Stub (P))
20983 then
20984 U := Corresponding_Spec_Of_Stub (P);
20985 end if;
20986
20987 when Type_Kind =>
20988 if Present (Full_View (E)) then
20989 U := Full_View (E);
20990 end if;
20991
20992 when others =>
20993 null;
20994 end case;
20995
20996 return U;
20997 end Unique_Entity;
20998
20999 -----------------
21000 -- Unique_Name --
21001 -----------------
21002
21003 function Unique_Name (E : Entity_Id) return String is
21004
21005 -- Names of E_Subprogram_Body or E_Package_Body entities are not
21006 -- reliable, as they may not include the overloading suffix. Instead,
21007 -- when looking for the name of E or one of its enclosing scope, we get
21008 -- the name of the corresponding Unique_Entity.
21009
21010 function Get_Scoped_Name (E : Entity_Id) return String;
21011 -- Return the name of E prefixed by all the names of the scopes to which
21012 -- E belongs, except for Standard.
21013
21014 ---------------------
21015 -- Get_Scoped_Name --
21016 ---------------------
21017
21018 function Get_Scoped_Name (E : Entity_Id) return String is
21019 Name : constant String := Get_Name_String (Chars (E));
21020 begin
21021 if Has_Fully_Qualified_Name (E)
21022 or else Scope (E) = Standard_Standard
21023 then
21024 return Name;
21025 else
21026 return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name;
21027 end if;
21028 end Get_Scoped_Name;
21029
21030 -- Start of processing for Unique_Name
21031
21032 begin
21033 if E = Standard_Standard then
21034 return Get_Name_String (Name_Standard);
21035
21036 elsif Scope (E) = Standard_Standard
21037 and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
21038 then
21039 return Get_Name_String (Name_Standard) & "__" &
21040 Get_Name_String (Chars (E));
21041
21042 elsif Ekind (E) = E_Enumeration_Literal then
21043 return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
21044
21045 else
21046 return Get_Scoped_Name (Unique_Entity (E));
21047 end if;
21048 end Unique_Name;
21049
21050 ---------------------
21051 -- Unit_Is_Visible --
21052 ---------------------
21053
21054 function Unit_Is_Visible (U : Entity_Id) return Boolean is
21055 Curr : constant Node_Id := Cunit (Current_Sem_Unit);
21056 Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
21057
21058 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
21059 -- For a child unit, check whether unit appears in a with_clause
21060 -- of a parent.
21061
21062 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
21063 -- Scan the context clause of one compilation unit looking for a
21064 -- with_clause for the unit in question.
21065
21066 ----------------------------
21067 -- Unit_In_Parent_Context --
21068 ----------------------------
21069
21070 function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
21071 begin
21072 if Unit_In_Context (Par_Unit) then
21073 return True;
21074
21075 elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
21076 return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
21077
21078 else
21079 return False;
21080 end if;
21081 end Unit_In_Parent_Context;
21082
21083 ---------------------
21084 -- Unit_In_Context --
21085 ---------------------
21086
21087 function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
21088 Clause : Node_Id;
21089
21090 begin
21091 Clause := First (Context_Items (Comp_Unit));
21092 while Present (Clause) loop
21093 if Nkind (Clause) = N_With_Clause then
21094 if Library_Unit (Clause) = U then
21095 return True;
21096
21097 -- The with_clause may denote a renaming of the unit we are
21098 -- looking for, eg. Text_IO which renames Ada.Text_IO.
21099
21100 elsif
21101 Renamed_Entity (Entity (Name (Clause))) =
21102 Defining_Entity (Unit (U))
21103 then
21104 return True;
21105 end if;
21106 end if;
21107
21108 Next (Clause);
21109 end loop;
21110
21111 return False;
21112 end Unit_In_Context;
21113
21114 -- Start of processing for Unit_Is_Visible
21115
21116 begin
21117 -- The currrent unit is directly visible
21118
21119 if Curr = U then
21120 return True;
21121
21122 elsif Unit_In_Context (Curr) then
21123 return True;
21124
21125 -- If the current unit is a body, check the context of the spec
21126
21127 elsif Nkind (Unit (Curr)) = N_Package_Body
21128 or else
21129 (Nkind (Unit (Curr)) = N_Subprogram_Body
21130 and then not Acts_As_Spec (Unit (Curr)))
21131 then
21132 if Unit_In_Context (Library_Unit (Curr)) then
21133 return True;
21134 end if;
21135 end if;
21136
21137 -- If the spec is a child unit, examine the parents
21138
21139 if Is_Child_Unit (Curr_Entity) then
21140 if Nkind (Unit (Curr)) in N_Unit_Body then
21141 return
21142 Unit_In_Parent_Context
21143 (Parent_Spec (Unit (Library_Unit (Curr))));
21144 else
21145 return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
21146 end if;
21147
21148 else
21149 return False;
21150 end if;
21151 end Unit_Is_Visible;
21152
21153 ------------------------------
21154 -- Universal_Interpretation --
21155 ------------------------------
21156
21157 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
21158 Index : Interp_Index;
21159 It : Interp;
21160
21161 begin
21162 -- The argument may be a formal parameter of an operator or subprogram
21163 -- with multiple interpretations, or else an expression for an actual.
21164
21165 if Nkind (Opnd) = N_Defining_Identifier
21166 or else not Is_Overloaded (Opnd)
21167 then
21168 if Etype (Opnd) = Universal_Integer
21169 or else Etype (Opnd) = Universal_Real
21170 then
21171 return Etype (Opnd);
21172 else
21173 return Empty;
21174 end if;
21175
21176 else
21177 Get_First_Interp (Opnd, Index, It);
21178 while Present (It.Typ) loop
21179 if It.Typ = Universal_Integer
21180 or else It.Typ = Universal_Real
21181 then
21182 return It.Typ;
21183 end if;
21184
21185 Get_Next_Interp (Index, It);
21186 end loop;
21187
21188 return Empty;
21189 end if;
21190 end Universal_Interpretation;
21191
21192 ---------------
21193 -- Unqualify --
21194 ---------------
21195
21196 function Unqualify (Expr : Node_Id) return Node_Id is
21197 begin
21198 -- Recurse to handle unlikely case of multiple levels of qualification
21199
21200 if Nkind (Expr) = N_Qualified_Expression then
21201 return Unqualify (Expression (Expr));
21202
21203 -- Normal case, not a qualified expression
21204
21205 else
21206 return Expr;
21207 end if;
21208 end Unqualify;
21209
21210 -----------------------
21211 -- Visible_Ancestors --
21212 -----------------------
21213
21214 function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
21215 List_1 : Elist_Id;
21216 List_2 : Elist_Id;
21217 Elmt : Elmt_Id;
21218
21219 begin
21220 pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ));
21221
21222 -- Collect all the parents and progenitors of Typ. If the full-view of
21223 -- private parents and progenitors is available then it is used to
21224 -- generate the list of visible ancestors; otherwise their partial
21225 -- view is added to the resulting list.
21226
21227 Collect_Parents
21228 (T => Typ,
21229 List => List_1,
21230 Use_Full_View => True);
21231
21232 Collect_Interfaces
21233 (T => Typ,
21234 Ifaces_List => List_2,
21235 Exclude_Parents => True,
21236 Use_Full_View => True);
21237
21238 -- Join the two lists. Avoid duplications because an interface may
21239 -- simultaneously be parent and progenitor of a type.
21240
21241 Elmt := First_Elmt (List_2);
21242 while Present (Elmt) loop
21243 Append_Unique_Elmt (Node (Elmt), List_1);
21244 Next_Elmt (Elmt);
21245 end loop;
21246
21247 return List_1;
21248 end Visible_Ancestors;
21249
21250 ----------------------
21251 -- Within_Init_Proc --
21252 ----------------------
21253
21254 function Within_Init_Proc return Boolean is
21255 S : Entity_Id;
21256
21257 begin
21258 S := Current_Scope;
21259 while not Is_Overloadable (S) loop
21260 if S = Standard_Standard then
21261 return False;
21262 else
21263 S := Scope (S);
21264 end if;
21265 end loop;
21266
21267 return Is_Init_Proc (S);
21268 end Within_Init_Proc;
21269
21270 ------------------
21271 -- Within_Scope --
21272 ------------------
21273
21274 function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is
21275 begin
21276 return Scope_Within_Or_Same (Scope (E), S);
21277 end Within_Scope;
21278
21279 ----------------
21280 -- Wrong_Type --
21281 ----------------
21282
21283 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
21284 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
21285 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
21286
21287 Matching_Field : Entity_Id;
21288 -- Entity to give a more precise suggestion on how to write a one-
21289 -- element positional aggregate.
21290
21291 function Has_One_Matching_Field return Boolean;
21292 -- Determines if Expec_Type is a record type with a single component or
21293 -- discriminant whose type matches the found type or is one dimensional
21294 -- array whose component type matches the found type. In the case of
21295 -- one discriminant, we ignore the variant parts. That's not accurate,
21296 -- but good enough for the warning.
21297
21298 ----------------------------
21299 -- Has_One_Matching_Field --
21300 ----------------------------
21301
21302 function Has_One_Matching_Field return Boolean is
21303 E : Entity_Id;
21304
21305 begin
21306 Matching_Field := Empty;
21307
21308 if Is_Array_Type (Expec_Type)
21309 and then Number_Dimensions (Expec_Type) = 1
21310 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type)
21311 then
21312 -- Use type name if available. This excludes multidimensional
21313 -- arrays and anonymous arrays.
21314
21315 if Comes_From_Source (Expec_Type) then
21316 Matching_Field := Expec_Type;
21317
21318 -- For an assignment, use name of target
21319
21320 elsif Nkind (Parent (Expr)) = N_Assignment_Statement
21321 and then Is_Entity_Name (Name (Parent (Expr)))
21322 then
21323 Matching_Field := Entity (Name (Parent (Expr)));
21324 end if;
21325
21326 return True;
21327
21328 elsif not Is_Record_Type (Expec_Type) then
21329 return False;
21330
21331 else
21332 E := First_Entity (Expec_Type);
21333 loop
21334 if No (E) then
21335 return False;
21336
21337 elsif not Ekind_In (E, E_Discriminant, E_Component)
21338 or else Nam_In (Chars (E), Name_uTag, Name_uParent)
21339 then
21340 Next_Entity (E);
21341
21342 else
21343 exit;
21344 end if;
21345 end loop;
21346
21347 if not Covers (Etype (E), Found_Type) then
21348 return False;
21349
21350 elsif Present (Next_Entity (E))
21351 and then (Ekind (E) = E_Component
21352 or else Ekind (Next_Entity (E)) = E_Discriminant)
21353 then
21354 return False;
21355
21356 else
21357 Matching_Field := E;
21358 return True;
21359 end if;
21360 end if;
21361 end Has_One_Matching_Field;
21362
21363 -- Start of processing for Wrong_Type
21364
21365 begin
21366 -- Don't output message if either type is Any_Type, or if a message
21367 -- has already been posted for this node. We need to do the latter
21368 -- check explicitly (it is ordinarily done in Errout), because we
21369 -- are using ! to force the output of the error messages.
21370
21371 if Expec_Type = Any_Type
21372 or else Found_Type = Any_Type
21373 or else Error_Posted (Expr)
21374 then
21375 return;
21376
21377 -- If one of the types is a Taft-Amendment type and the other it its
21378 -- completion, it must be an illegal use of a TAT in the spec, for
21379 -- which an error was already emitted. Avoid cascaded errors.
21380
21381 elsif Is_Incomplete_Type (Expec_Type)
21382 and then Has_Completion_In_Body (Expec_Type)
21383 and then Full_View (Expec_Type) = Etype (Expr)
21384 then
21385 return;
21386
21387 elsif Is_Incomplete_Type (Etype (Expr))
21388 and then Has_Completion_In_Body (Etype (Expr))
21389 and then Full_View (Etype (Expr)) = Expec_Type
21390 then
21391 return;
21392
21393 -- In an instance, there is an ongoing problem with completion of
21394 -- type derived from private types. Their structure is what Gigi
21395 -- expects, but the Etype is the parent type rather than the
21396 -- derived private type itself. Do not flag error in this case. The
21397 -- private completion is an entity without a parent, like an Itype.
21398 -- Similarly, full and partial views may be incorrect in the instance.
21399 -- There is no simple way to insure that it is consistent ???
21400
21401 -- A similar view discrepancy can happen in an inlined body, for the
21402 -- same reason: inserted body may be outside of the original package
21403 -- and only partial views are visible at the point of insertion.
21404
21405 elsif In_Instance or else In_Inlined_Body then
21406 if Etype (Etype (Expr)) = Etype (Expected_Type)
21407 and then
21408 (Has_Private_Declaration (Expected_Type)
21409 or else Has_Private_Declaration (Etype (Expr)))
21410 and then No (Parent (Expected_Type))
21411 then
21412 return;
21413
21414 elsif Nkind (Parent (Expr)) = N_Qualified_Expression
21415 and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type
21416 then
21417 return;
21418
21419 elsif Is_Private_Type (Expected_Type)
21420 and then Present (Full_View (Expected_Type))
21421 and then Covers (Full_View (Expected_Type), Etype (Expr))
21422 then
21423 return;
21424
21425 -- Conversely, type of expression may be the private one
21426
21427 elsif Is_Private_Type (Base_Type (Etype (Expr)))
21428 and then Full_View (Base_Type (Etype (Expr))) = Expected_Type
21429 then
21430 return;
21431 end if;
21432 end if;
21433
21434 -- An interesting special check. If the expression is parenthesized
21435 -- and its type corresponds to the type of the sole component of the
21436 -- expected record type, or to the component type of the expected one
21437 -- dimensional array type, then assume we have a bad aggregate attempt.
21438
21439 if Nkind (Expr) in N_Subexpr
21440 and then Paren_Count (Expr) /= 0
21441 and then Has_One_Matching_Field
21442 then
21443 Error_Msg_N ("positional aggregate cannot have one component", Expr);
21444
21445 if Present (Matching_Field) then
21446 if Is_Array_Type (Expec_Type) then
21447 Error_Msg_NE
21448 ("\write instead `&''First ='> ...`", Expr, Matching_Field);
21449 else
21450 Error_Msg_NE
21451 ("\write instead `& ='> ...`", Expr, Matching_Field);
21452 end if;
21453 end if;
21454
21455 -- Another special check, if we are looking for a pool-specific access
21456 -- type and we found an E_Access_Attribute_Type, then we have the case
21457 -- of an Access attribute being used in a context which needs a pool-
21458 -- specific type, which is never allowed. The one extra check we make
21459 -- is that the expected designated type covers the Found_Type.
21460
21461 elsif Is_Access_Type (Expec_Type)
21462 and then Ekind (Found_Type) = E_Access_Attribute_Type
21463 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
21464 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
21465 and then Covers
21466 (Designated_Type (Expec_Type), Designated_Type (Found_Type))
21467 then
21468 Error_Msg_N -- CODEFIX
21469 ("result must be general access type!", Expr);
21470 Error_Msg_NE -- CODEFIX
21471 ("add ALL to }!", Expr, Expec_Type);
21472
21473 -- Another special check, if the expected type is an integer type,
21474 -- but the expression is of type System.Address, and the parent is
21475 -- an addition or subtraction operation whose left operand is the
21476 -- expression in question and whose right operand is of an integral
21477 -- type, then this is an attempt at address arithmetic, so give
21478 -- appropriate message.
21479
21480 elsif Is_Integer_Type (Expec_Type)
21481 and then Is_RTE (Found_Type, RE_Address)
21482 and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract)
21483 and then Expr = Left_Opnd (Parent (Expr))
21484 and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
21485 then
21486 Error_Msg_N
21487 ("address arithmetic not predefined in package System",
21488 Parent (Expr));
21489 Error_Msg_N
21490 ("\possible missing with/use of System.Storage_Elements",
21491 Parent (Expr));
21492 return;
21493
21494 -- If the expected type is an anonymous access type, as for access
21495 -- parameters and discriminants, the error is on the designated types.
21496
21497 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
21498 if Comes_From_Source (Expec_Type) then
21499 Error_Msg_NE ("expected}!", Expr, Expec_Type);
21500 else
21501 Error_Msg_NE
21502 ("expected an access type with designated}",
21503 Expr, Designated_Type (Expec_Type));
21504 end if;
21505
21506 if Is_Access_Type (Found_Type)
21507 and then not Comes_From_Source (Found_Type)
21508 then
21509 Error_Msg_NE
21510 ("\\found an access type with designated}!",
21511 Expr, Designated_Type (Found_Type));
21512 else
21513 if From_Limited_With (Found_Type) then
21514 Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
21515 Error_Msg_Qual_Level := 99;
21516 Error_Msg_NE -- CODEFIX
21517 ("\\missing `WITH &;", Expr, Scope (Found_Type));
21518 Error_Msg_Qual_Level := 0;
21519 else
21520 Error_Msg_NE ("found}!", Expr, Found_Type);
21521 end if;
21522 end if;
21523
21524 -- Normal case of one type found, some other type expected
21525
21526 else
21527 -- If the names of the two types are the same, see if some number
21528 -- of levels of qualification will help. Don't try more than three
21529 -- levels, and if we get to standard, it's no use (and probably
21530 -- represents an error in the compiler) Also do not bother with
21531 -- internal scope names.
21532
21533 declare
21534 Expec_Scope : Entity_Id;
21535 Found_Scope : Entity_Id;
21536
21537 begin
21538 Expec_Scope := Expec_Type;
21539 Found_Scope := Found_Type;
21540
21541 for Levels in Nat range 0 .. 3 loop
21542 if Chars (Expec_Scope) /= Chars (Found_Scope) then
21543 Error_Msg_Qual_Level := Levels;
21544 exit;
21545 end if;
21546
21547 Expec_Scope := Scope (Expec_Scope);
21548 Found_Scope := Scope (Found_Scope);
21549
21550 exit when Expec_Scope = Standard_Standard
21551 or else Found_Scope = Standard_Standard
21552 or else not Comes_From_Source (Expec_Scope)
21553 or else not Comes_From_Source (Found_Scope);
21554 end loop;
21555 end;
21556
21557 if Is_Record_Type (Expec_Type)
21558 and then Present (Corresponding_Remote_Type (Expec_Type))
21559 then
21560 Error_Msg_NE ("expected}!", Expr,
21561 Corresponding_Remote_Type (Expec_Type));
21562 else
21563 Error_Msg_NE ("expected}!", Expr, Expec_Type);
21564 end if;
21565
21566 if Is_Entity_Name (Expr)
21567 and then Is_Package_Or_Generic_Package (Entity (Expr))
21568 then
21569 Error_Msg_N ("\\found package name!", Expr);
21570
21571 elsif Is_Entity_Name (Expr)
21572 and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure)
21573 then
21574 if Ekind (Expec_Type) = E_Access_Subprogram_Type then
21575 Error_Msg_N
21576 ("found procedure name, possibly missing Access attribute!",
21577 Expr);
21578 else
21579 Error_Msg_N
21580 ("\\found procedure name instead of function!", Expr);
21581 end if;
21582
21583 elsif Nkind (Expr) = N_Function_Call
21584 and then Ekind (Expec_Type) = E_Access_Subprogram_Type
21585 and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
21586 and then No (Parameter_Associations (Expr))
21587 then
21588 Error_Msg_N
21589 ("found function name, possibly missing Access attribute!",
21590 Expr);
21591
21592 -- Catch common error: a prefix or infix operator which is not
21593 -- directly visible because the type isn't.
21594
21595 elsif Nkind (Expr) in N_Op
21596 and then Is_Overloaded (Expr)
21597 and then not Is_Immediately_Visible (Expec_Type)
21598 and then not Is_Potentially_Use_Visible (Expec_Type)
21599 and then not In_Use (Expec_Type)
21600 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
21601 then
21602 Error_Msg_N
21603 ("operator of the type is not directly visible!", Expr);
21604
21605 elsif Ekind (Found_Type) = E_Void
21606 and then Present (Parent (Found_Type))
21607 and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
21608 then
21609 Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
21610
21611 else
21612 Error_Msg_NE ("\\found}!", Expr, Found_Type);
21613 end if;
21614
21615 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
21616 -- of the same modular type, and (M1 and M2) = 0 was intended.
21617
21618 if Expec_Type = Standard_Boolean
21619 and then Is_Modular_Integer_Type (Found_Type)
21620 and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
21621 and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
21622 then
21623 declare
21624 Op : constant Node_Id := Right_Opnd (Parent (Expr));
21625 L : constant Node_Id := Left_Opnd (Op);
21626 R : constant Node_Id := Right_Opnd (Op);
21627
21628 begin
21629 -- The case for the message is when the left operand of the
21630 -- comparison is the same modular type, or when it is an
21631 -- integer literal (or other universal integer expression),
21632 -- which would have been typed as the modular type if the
21633 -- parens had been there.
21634
21635 if (Etype (L) = Found_Type
21636 or else
21637 Etype (L) = Universal_Integer)
21638 and then Is_Integer_Type (Etype (R))
21639 then
21640 Error_Msg_N
21641 ("\\possible missing parens for modular operation", Expr);
21642 end if;
21643 end;
21644 end if;
21645
21646 -- Reset error message qualification indication
21647
21648 Error_Msg_Qual_Level := 0;
21649 end if;
21650 end Wrong_Type;
21651
21652 --------------------------------
21653 -- Yields_Synchronized_Object --
21654 --------------------------------
21655
21656 function Yields_Synchronized_Object (Typ : Entity_Id) return Boolean is
21657 Has_Sync_Comp : Boolean := False;
21658 Id : Entity_Id;
21659
21660 begin
21661 -- An array type yields a synchronized object if its component type
21662 -- yields a synchronized object.
21663
21664 if Is_Array_Type (Typ) then
21665 return Yields_Synchronized_Object (Component_Type (Typ));
21666
21667 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object
21668 -- yields a synchronized object by default.
21669
21670 elsif Is_Descendant_Of_Suspension_Object (Typ) then
21671 return True;
21672
21673 -- A protected type yields a synchronized object by default
21674
21675 elsif Is_Protected_Type (Typ) then
21676 return True;
21677
21678 -- A record type or type extension yields a synchronized object when its
21679 -- discriminants (if any) lack default values and all components are of
21680 -- a type that yelds a synchronized object.
21681
21682 elsif Is_Record_Type (Typ) then
21683
21684 -- Inspect all entities defined in the scope of the type, looking for
21685 -- components of a type that does not yeld a synchronized object or
21686 -- for discriminants with default values.
21687
21688 Id := First_Entity (Typ);
21689 while Present (Id) loop
21690 if Comes_From_Source (Id) then
21691 if Ekind (Id) = E_Component then
21692 if Yields_Synchronized_Object (Etype (Id)) then
21693 Has_Sync_Comp := True;
21694
21695 -- The component does not yield a synchronized object
21696
21697 else
21698 return False;
21699 end if;
21700
21701 elsif Ekind (Id) = E_Discriminant
21702 and then Present (Expression (Parent (Id)))
21703 then
21704 return False;
21705 end if;
21706 end if;
21707
21708 Next_Entity (Id);
21709 end loop;
21710
21711 -- Ensure that the parent type of a type extension yields a
21712 -- synchronized object.
21713
21714 if Etype (Typ) /= Typ
21715 and then not Yields_Synchronized_Object (Etype (Typ))
21716 then
21717 return False;
21718 end if;
21719
21720 -- If we get here, then all discriminants lack default values and all
21721 -- components are of a type that yields a synchronized object.
21722
21723 return Has_Sync_Comp;
21724
21725 -- A synchronized interface type yields a synchronized object by default
21726
21727 elsif Is_Synchronized_Interface (Typ) then
21728 return True;
21729
21730 -- A task type yelds a synchronized object by default
21731
21732 elsif Is_Task_Type (Typ) then
21733 return True;
21734
21735 -- Otherwise the type does not yield a synchronized object
21736
21737 else
21738 return False;
21739 end if;
21740 end Yields_Synchronized_Object;
21741
21742 ---------------------------
21743 -- Yields_Universal_Type --
21744 ---------------------------
21745
21746 function Yields_Universal_Type (N : Node_Id) return Boolean is
21747 begin
21748 -- Integer and real literals are of a universal type
21749
21750 if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
21751 return True;
21752
21753 -- The values of certain attributes are of a universal type
21754
21755 elsif Nkind (N) = N_Attribute_Reference then
21756 return
21757 Universal_Type_Attribute (Get_Attribute_Id (Attribute_Name (N)));
21758
21759 -- ??? There are possibly other cases to consider
21760
21761 else
21762 return False;
21763 end if;
21764 end Yields_Universal_Type;
21765
21766 end Sem_Util;