?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* gimplify.c (find_single_pointer_decl_1): New static function.
[official-gcc.git] / gcc / ada / sem_ch9.adb
blob190706c4e11537976ffcc5fa0237d648889341bd
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ C H 9 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2005 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Exp_Ch9;
32 with Elists; use Elists;
33 with Freeze; use Freeze;
34 with Itypes; use Itypes;
35 with Lib.Xref; use Lib.Xref;
36 with Nlists; use Nlists;
37 with Nmake; use Nmake;
38 with Opt; use Opt;
39 with Restrict; use Restrict;
40 with Rident; use Rident;
41 with Rtsfind; use Rtsfind;
42 with Sem; use Sem;
43 with Sem_Ch3; use Sem_Ch3;
44 with Sem_Ch5; use Sem_Ch5;
45 with Sem_Ch6; use Sem_Ch6;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Eval; use Sem_Eval;
48 with Sem_Res; use Sem_Res;
49 with Sem_Type; use Sem_Type;
50 with Sem_Util; use Sem_Util;
51 with Sem_Warn; use Sem_Warn;
52 with Snames; use Snames;
53 with Stand; use Stand;
54 with Sinfo; use Sinfo;
55 with Style;
56 with Tbuild; use Tbuild;
57 with Uintp; use Uintp;
58
59 package body Sem_Ch9 is
60
61 -----------------------
62 -- Local Subprograms --
63 -----------------------
64
65 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
66 -- Given either a protected definition or a task definition in D, check
67 -- the corresponding restriction parameter identifier R, and if it is set,
68 -- count the entries (checking the static requirement), and compare with
69 -- the given maximum.
70
71 procedure Check_Overriding_Indicator (Def : Node_Id);
72 -- Ada 2005 (AI-397): Check the overriding indicator of entries and
73 -- subprograms of protected or task types. Def is the definition of
74 -- the protected or task type.
75
76 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
77 -- Find entity in corresponding task or protected declaration. Use full
78 -- view if first declaration was for an incomplete type.
79
80 procedure Install_Declarations (Spec : Entity_Id);
81 -- Utility to make visible in corresponding body the entities defined
82 -- in task, protected type declaration, or entry declaration.
83
84 -----------------------------
85 -- Analyze_Abort_Statement --
86 -----------------------------
87
88 procedure Analyze_Abort_Statement (N : Node_Id) is
89 T_Name : Node_Id;
90
91 begin
92 Tasking_Used := True;
93 T_Name := First (Names (N));
94 while Present (T_Name) loop
95 Analyze (T_Name);
96
97 if not Is_Task_Type (Etype (T_Name)) then
98 Error_Msg_N ("expect task name for ABORT", T_Name);
99 return;
100 else
101 Resolve (T_Name);
102 end if;
103
104 Next (T_Name);
105 end loop;
106
107 Check_Restriction (No_Abort_Statements, N);
108 Check_Potentially_Blocking_Operation (N);
109 end Analyze_Abort_Statement;
110
111 --------------------------------
112 -- Analyze_Accept_Alternative --
113 --------------------------------
114
115 procedure Analyze_Accept_Alternative (N : Node_Id) is
116 begin
117 Tasking_Used := True;
118
119 if Present (Pragmas_Before (N)) then
120 Analyze_List (Pragmas_Before (N));
121 end if;
122
123 if Present (Condition (N)) then
124 Analyze_And_Resolve (Condition (N), Any_Boolean);
125 end if;
126
127 Analyze (Accept_Statement (N));
128
129 if Is_Non_Empty_List (Statements (N)) then
130 Analyze_Statements (Statements (N));
131 end if;
132 end Analyze_Accept_Alternative;
133
134 ------------------------------
135 -- Analyze_Accept_Statement --
136 ------------------------------
137
138 procedure Analyze_Accept_Statement (N : Node_Id) is
139 Nam : constant Entity_Id := Entry_Direct_Name (N);
140 Formals : constant List_Id := Parameter_Specifications (N);
141 Index : constant Node_Id := Entry_Index (N);
142 Stats : constant Node_Id := Handled_Statement_Sequence (N);
143 Accept_Id : Entity_Id;
144 Entry_Nam : Entity_Id;
145 E : Entity_Id;
146 Kind : Entity_Kind;
147 Task_Nam : Entity_Id;
148
149 -----------------------
150 -- Actual_Index_Type --
151 -----------------------
152
153 function Actual_Index_Type (E : Entity_Id) return Entity_Id;
154 -- If the bounds of an entry family depend on task discriminants,
155 -- create a new index type where a discriminant is replaced by the
156 -- local variable that renames it in the task body.
157
158 function Actual_Index_Type (E : Entity_Id) return Entity_Id is
159 Typ : constant Entity_Id := Entry_Index_Type (E);
160 Lo : constant Node_Id := Type_Low_Bound (Typ);
161 Hi : constant Node_Id := Type_High_Bound (Typ);
162 New_T : Entity_Id;
163
164 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
165 -- If bound is discriminant reference, replace with corresponding
166 -- local variable of the same name.
167
168 -----------------------------
169 -- Actual_Discriminant_Ref --
170 -----------------------------
171
172 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
173 Typ : constant Entity_Id := Etype (Bound);
174 Ref : Node_Id;
175
176 begin
177 if not Is_Entity_Name (Bound)
178 or else Ekind (Entity (Bound)) /= E_Discriminant
179 then
180 return Bound;
181
182 else
183 Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
184 Analyze (Ref);
185 Resolve (Ref, Typ);
186 return Ref;
187 end if;
188 end Actual_Discriminant_Ref;
189
190 -- Start of processing for Actual_Index_Type
191
192 begin
193 if not Has_Discriminants (Task_Nam)
194 or else (not Is_Entity_Name (Lo)
195 and then not Is_Entity_Name (Hi))
196 then
197 return Entry_Index_Type (E);
198 else
199 New_T := Create_Itype (Ekind (Typ), N);
200 Set_Etype (New_T, Base_Type (Typ));
201 Set_Size_Info (New_T, Typ);
202 Set_RM_Size (New_T, RM_Size (Typ));
203 Set_Scalar_Range (New_T,
204 Make_Range (Sloc (N),
205 Low_Bound => Actual_Discriminant_Ref (Lo),
206 High_Bound => Actual_Discriminant_Ref (Hi)));
207
208 return New_T;
209 end if;
210 end Actual_Index_Type;
211
212 -- Start of processing for Analyze_Accept_Statement
213
214 begin
215 Tasking_Used := True;
216
217 -- Entry name is initialized to Any_Id. It should get reset to the
218 -- matching entry entity. An error is signalled if it is not reset.
219
220 Entry_Nam := Any_Id;
221
222 for J in reverse 0 .. Scope_Stack.Last loop
223 Task_Nam := Scope_Stack.Table (J).Entity;
224 exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
225 Kind := Ekind (Task_Nam);
226
227 if Kind /= E_Block and then Kind /= E_Loop
228 and then not Is_Entry (Task_Nam)
229 then
230 Error_Msg_N ("enclosing body of accept must be a task", N);
231 return;
232 end if;
233 end loop;
234
235 if Ekind (Etype (Task_Nam)) /= E_Task_Type then
236 Error_Msg_N ("invalid context for accept statement", N);
237 return;
238 end if;
239
240 -- In order to process the parameters, we create a defining
241 -- identifier that can be used as the name of the scope. The
242 -- name of the accept statement itself is not a defining identifier,
243 -- and we cannot use its name directly because the task may have
244 -- any number of accept statements for the same entry.
245
246 if Present (Index) then
247 Accept_Id := New_Internal_Entity
248 (E_Entry_Family, Current_Scope, Sloc (N), 'E');
249 else
250 Accept_Id := New_Internal_Entity
251 (E_Entry, Current_Scope, Sloc (N), 'E');
252 end if;
253
254 Set_Etype (Accept_Id, Standard_Void_Type);
255 Set_Accept_Address (Accept_Id, New_Elmt_List);
256
257 if Present (Formals) then
258 New_Scope (Accept_Id);
259 Process_Formals (Formals, N);
260 Create_Extra_Formals (Accept_Id);
261 End_Scope;
262 end if;
263
264 -- We set the default expressions processed flag because we don't
265 -- need default expression functions. This is really more like a
266 -- body entity than a spec entity anyway.
267
268 Set_Default_Expressions_Processed (Accept_Id);
269
270 E := First_Entity (Etype (Task_Nam));
271 while Present (E) loop
272 if Chars (E) = Chars (Nam)
273 and then (Ekind (E) = Ekind (Accept_Id))
274 and then Type_Conformant (Accept_Id, E)
275 then
276 Entry_Nam := E;
277 exit;
278 end if;
279
280 Next_Entity (E);
281 end loop;
282
283 if Entry_Nam = Any_Id then
284 Error_Msg_N ("no entry declaration matches accept statement", N);
285 return;
286 else
287 Set_Entity (Nam, Entry_Nam);
288 Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False);
289 Style.Check_Identifier (Nam, Entry_Nam);
290 end if;
291
292 -- Verify that the entry is not hidden by a procedure declared in
293 -- the current block (pathological but possible).
294
295 if Current_Scope /= Task_Nam then
296 declare
297 E1 : Entity_Id;
298
299 begin
300 E1 := First_Entity (Current_Scope);
301
302 while Present (E1) loop
303
304 if Ekind (E1) = E_Procedure
305 and then Chars (E1) = Chars (Entry_Nam)
306 and then Type_Conformant (E1, Entry_Nam)
307 then
308 Error_Msg_N ("entry name is not visible", N);
309 end if;
310
311 Next_Entity (E1);
312 end loop;
313 end;
314 end if;
315
316 Set_Convention (Accept_Id, Convention (Entry_Nam));
317 Check_Fully_Conformant (Accept_Id, Entry_Nam, N);
318
319 for J in reverse 0 .. Scope_Stack.Last loop
320 exit when Task_Nam = Scope_Stack.Table (J).Entity;
321
322 if Entry_Nam = Scope_Stack.Table (J).Entity then
323 Error_Msg_N ("duplicate accept statement for same entry", N);
324 end if;
325
326 end loop;
327
328 declare
329 P : Node_Id := N;
330 begin
331 loop
332 P := Parent (P);
333 case Nkind (P) is
334 when N_Task_Body | N_Compilation_Unit =>
335 exit;
336 when N_Asynchronous_Select =>
337 Error_Msg_N ("accept statements are not allowed within" &
338 " an asynchronous select inner" &
339 " to the enclosing task body", N);
340 exit;
341 when others =>
342 null;
343 end case;
344 end loop;
345 end;
346
347 if Ekind (E) = E_Entry_Family then
348 if No (Index) then
349 Error_Msg_N ("missing entry index in accept for entry family", N);
350 else
351 Analyze_And_Resolve (Index, Entry_Index_Type (E));
352 Apply_Range_Check (Index, Actual_Index_Type (E));
353 end if;
354
355 elsif Present (Index) then
356 Error_Msg_N ("invalid entry index in accept for simple entry", N);
357 end if;
358
359 -- If label declarations present, analyze them. They are declared
360 -- in the enclosing task, but their enclosing scope is the entry itself,
361 -- so that goto's to the label are recognized as local to the accept.
362
363 if Present (Declarations (N)) then
364
365 declare
366 Decl : Node_Id;
367 Id : Entity_Id;
368
369 begin
370 Decl := First (Declarations (N));
371
372 while Present (Decl) loop
373 Analyze (Decl);
374
375 pragma Assert
376 (Nkind (Decl) = N_Implicit_Label_Declaration);
377
378 Id := Defining_Identifier (Decl);
379 Set_Enclosing_Scope (Id, Entry_Nam);
380 Next (Decl);
381 end loop;
382 end;
383 end if;
384
385 -- If statements are present, they must be analyzed in the context
386 -- of the entry, so that references to formals are correctly resolved.
387 -- We also have to add the declarations that are required by the
388 -- expansion of the accept statement in this case if expansion active.
389
390 -- In the case of a select alternative of a selective accept,
391 -- the expander references the address declaration even if there
392 -- is no statement list.
393 -- We also need to create the renaming declarations for the local
394 -- variables that will replace references to the formals within
395 -- the accept.
396
397 Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
398
399 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
400 -- fields on all entry formals (this loop ignores all other entities).
401 -- Reset Set_Referenced and Has_Pragma_Unreferenced as well, so that
402 -- we can post accurate warnings on each accept statement for the same
403 -- entry.
404
405 E := First_Entity (Entry_Nam);
406 while Present (E) loop
407 if Is_Formal (E) then
408 Set_Never_Set_In_Source (E, True);
409 Set_Is_True_Constant (E, False);
410 Set_Current_Value (E, Empty);
411 Set_Referenced (E, False);
412 Set_Has_Pragma_Unreferenced (E, False);
413 end if;
414
415 Next_Entity (E);
416 end loop;
417
418 -- Analyze statements if present
419
420 if Present (Stats) then
421 New_Scope (Entry_Nam);
422 Install_Declarations (Entry_Nam);
423
424 Set_Actual_Subtypes (N, Current_Scope);
425
426 Analyze (Stats);
427 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam);
428 End_Scope;
429 end if;
430
431 -- Some warning checks
432
433 Check_Potentially_Blocking_Operation (N);
434 Check_References (Entry_Nam, N);
435 Set_Entry_Accepted (Entry_Nam);
436 end Analyze_Accept_Statement;
437
438 ---------------------------------
439 -- Analyze_Asynchronous_Select --
440 ---------------------------------
441
442 procedure Analyze_Asynchronous_Select (N : Node_Id) is
443 begin
444 Tasking_Used := True;
445 Check_Restriction (Max_Asynchronous_Select_Nesting, N);
446 Check_Restriction (No_Select_Statements, N);
447
448 -- Analyze the statements. We analyze statements in the abortable part
449 -- first, because this is the section that is executed first, and that
450 -- way our remembering of saved values and checks is accurate.
451
452 Analyze_Statements (Statements (Abortable_Part (N)));
453 Analyze (Triggering_Alternative (N));
454 end Analyze_Asynchronous_Select;
455
456 ------------------------------------
457 -- Analyze_Conditional_Entry_Call --
458 ------------------------------------
459
460 procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
461 begin
462 Check_Restriction (No_Select_Statements, N);
463 Tasking_Used := True;
464 Analyze (Entry_Call_Alternative (N));
465 Analyze_Statements (Else_Statements (N));
466 end Analyze_Conditional_Entry_Call;
467
468 --------------------------------
469 -- Analyze_Delay_Alternative --
470 --------------------------------
471
472 procedure Analyze_Delay_Alternative (N : Node_Id) is
473 Expr : Node_Id;
474
475 begin
476 Tasking_Used := True;
477 Check_Restriction (No_Delay, N);
478
479 if Present (Pragmas_Before (N)) then
480 Analyze_List (Pragmas_Before (N));
481 end if;
482
483 if Nkind (Parent (N)) = N_Selective_Accept
484 or else Nkind (Parent (N)) = N_Timed_Entry_Call
485 then
486 Expr := Expression (Delay_Statement (N));
487
488 -- defer full analysis until the statement is expanded, to insure
489 -- that generated code does not move past the guard. The delay
490 -- expression is only evaluated if the guard is open.
491
492 if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
493 Pre_Analyze_And_Resolve (Expr, Standard_Duration);
494
495 else
496 Pre_Analyze_And_Resolve (Expr);
497 end if;
498
499 if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement and then
500 not Is_RTE (Base_Type (Etype (Expr)), RO_CA_Time) and then
501 not Is_RTE (Base_Type (Etype (Expr)), RO_RT_Time)
502 then
503 Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
504 end if;
505
506 Check_Restriction (No_Fixed_Point, Expr);
507 else
508 Analyze (Delay_Statement (N));
509 end if;
510
511 if Present (Condition (N)) then
512 Analyze_And_Resolve (Condition (N), Any_Boolean);
513 end if;
514
515 if Is_Non_Empty_List (Statements (N)) then
516 Analyze_Statements (Statements (N));
517 end if;
518 end Analyze_Delay_Alternative;
519
520 ----------------------------
521 -- Analyze_Delay_Relative --
522 ----------------------------
523
524 procedure Analyze_Delay_Relative (N : Node_Id) is
525 E : constant Node_Id := Expression (N);
526
527 begin
528 Check_Restriction (No_Relative_Delay, N);
529 Tasking_Used := True;
530 Check_Restriction (No_Delay, N);
531 Check_Potentially_Blocking_Operation (N);
532 Analyze_And_Resolve (E, Standard_Duration);
533 Check_Restriction (No_Fixed_Point, E);
534 end Analyze_Delay_Relative;
535
536 -------------------------
537 -- Analyze_Delay_Until --
538 -------------------------
539
540 procedure Analyze_Delay_Until (N : Node_Id) is
541 E : constant Node_Id := Expression (N);
542
543 begin
544 Tasking_Used := True;
545 Check_Restriction (No_Delay, N);
546 Check_Potentially_Blocking_Operation (N);
547 Analyze (E);
548
549 if not Is_RTE (Base_Type (Etype (E)), RO_CA_Time) and then
550 not Is_RTE (Base_Type (Etype (E)), RO_RT_Time)
551 then
552 Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
553 end if;
554 end Analyze_Delay_Until;
555
556 ------------------------
557 -- Analyze_Entry_Body --
558 ------------------------
559
560 procedure Analyze_Entry_Body (N : Node_Id) is
561 Id : constant Entity_Id := Defining_Identifier (N);
562 Decls : constant List_Id := Declarations (N);
563 Stats : constant Node_Id := Handled_Statement_Sequence (N);
564 Formals : constant Node_Id := Entry_Body_Formal_Part (N);
565 P_Type : constant Entity_Id := Current_Scope;
566 Entry_Name : Entity_Id;
567 E : Entity_Id;
568
569 begin
570 Tasking_Used := True;
571
572 -- Entry_Name is initialized to Any_Id. It should get reset to the
573 -- matching entry entity. An error is signalled if it is not reset
574
575 Entry_Name := Any_Id;
576
577 Analyze (Formals);
578
579 if Present (Entry_Index_Specification (Formals)) then
580 Set_Ekind (Id, E_Entry_Family);
581 else
582 Set_Ekind (Id, E_Entry);
583 end if;
584
585 Set_Scope (Id, Current_Scope);
586 Set_Etype (Id, Standard_Void_Type);
587 Set_Accept_Address (Id, New_Elmt_List);
588
589 E := First_Entity (P_Type);
590 while Present (E) loop
591 if Chars (E) = Chars (Id)
592 and then (Ekind (E) = Ekind (Id))
593 and then Type_Conformant (Id, E)
594 then
595 Entry_Name := E;
596 Set_Convention (Id, Convention (E));
597 Set_Corresponding_Body (Parent (Entry_Name), Id);
598 Check_Fully_Conformant (Id, E, N);
599
600 if Ekind (Id) = E_Entry_Family then
601 if not Fully_Conformant_Discrete_Subtypes (
602 Discrete_Subtype_Definition (Parent (E)),
603 Discrete_Subtype_Definition
604 (Entry_Index_Specification (Formals)))
605 then
606 Error_Msg_N
607 ("index not fully conformant with previous declaration",
608 Discrete_Subtype_Definition
609 (Entry_Index_Specification (Formals)));
610
611 else
612 -- The elaboration of the entry body does not recompute
613 -- the bounds of the index, which may have side effects.
614 -- Inherit the bounds from the entry declaration. This
615 -- is critical if the entry has a per-object constraint.
616 -- If a bound is given by a discriminant, it must be
617 -- reanalyzed in order to capture the discriminal of the
618 -- current entry, rather than that of the protected type.
619
620 declare
621 Index_Spec : constant Node_Id :=
622 Entry_Index_Specification (Formals);
623
624 Def : constant Node_Id :=
625 New_Copy_Tree
626 (Discrete_Subtype_Definition (Parent (E)));
627
628 begin
629 if Nkind
630 (Original_Node
631 (Discrete_Subtype_Definition (Index_Spec))) = N_Range
632 then
633 Set_Etype (Def, Empty);
634 Set_Analyzed (Def, False);
635 Set_Discrete_Subtype_Definition (Index_Spec, Def);
636 Set_Analyzed (Low_Bound (Def), False);
637 Set_Analyzed (High_Bound (Def), False);
638
639 if Denotes_Discriminant (Low_Bound (Def)) then
640 Set_Entity (Low_Bound (Def), Empty);
641 end if;
642
643 if Denotes_Discriminant (High_Bound (Def)) then
644 Set_Entity (High_Bound (Def), Empty);
645 end if;
646
647 Analyze (Def);
648 Make_Index (Def, Index_Spec);
649 Set_Etype
650 (Defining_Identifier (Index_Spec), Etype (Def));
651 end if;
652 end;
653 end if;
654 end if;
655
656 exit;
657 end if;
658
659 Next_Entity (E);
660 end loop;
661
662 if Entry_Name = Any_Id then
663 Error_Msg_N ("no entry declaration matches entry body", N);
664 return;
665
666 elsif Has_Completion (Entry_Name) then
667 Error_Msg_N ("duplicate entry body", N);
668 return;
669
670 else
671 Set_Has_Completion (Entry_Name);
672 Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False);
673 Style.Check_Identifier (Id, Entry_Name);
674 end if;
675
676 Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
677 New_Scope (Entry_Name);
678
679 Exp_Ch9.Expand_Entry_Body_Declarations (N);
680 Install_Declarations (Entry_Name);
681 Set_Actual_Subtypes (N, Current_Scope);
682
683 -- The entity for the protected subprogram corresponding to the entry
684 -- has been created. We retain the name of this entity in the entry
685 -- body, for use when the corresponding subprogram body is created.
686 -- Note that entry bodies have to corresponding_spec, and there is no
687 -- easy link back in the tree between the entry body and the entity for
688 -- the entry itself.
689
690 Set_Protected_Body_Subprogram (Id,
691 Protected_Body_Subprogram (Entry_Name));
692
693 if Present (Decls) then
694 Analyze_Declarations (Decls);
695 end if;
696
697 if Present (Stats) then
698 Analyze (Stats);
699 end if;
700
701 -- Check for unreferenced variables etc. Before the Check_References
702 -- call, we transfer Never_Set_In_Source and Referenced flags from
703 -- parameters in the spec to the corresponding entities in the body,
704 -- since we want the warnings on the body entities. Note that we do
705 -- not have to transfer Referenced_As_LHS, since that flag can only
706 -- be set for simple variables.
707
708 -- At the same time, we set the flags on the spec entities to suppress
709 -- any warnings on the spec formals, since we also scan the spec.
710
711 declare
712 E1 : Entity_Id;
713 E2 : Entity_Id;
714
715 begin
716 E1 := First_Entity (Entry_Name);
717 while Present (E1) loop
718 E2 := First_Entity (Id);
719 while Present (E2) loop
720 exit when Chars (E1) = Chars (E2);
721 Next_Entity (E2);
722 end loop;
723
724 -- If no matching body entity, then we already had
725 -- a detected error of some kind, so just forget
726 -- about worrying about these warnings.
727
728 if No (E2) then
729 goto Continue;
730 end if;
731
732 if Ekind (E1) = E_Out_Parameter then
733 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
734 Set_Never_Set_In_Source (E1, False);
735 end if;
736
737 Set_Referenced (E2, Referenced (E1));
738 Set_Referenced (E1);
739
740 <<Continue>>
741 Next_Entity (E1);
742 end loop;
743
744 Check_References (Id);
745 end;
746
747 -- We still need to check references for the spec, since objects
748 -- declared in the body are chained (in the First_Entity sense) to
749 -- the spec rather than the body in the case of entries.
750
751 Check_References (Entry_Name);
752
753 -- Process the end label, and terminate the scope
754
755 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name);
756 End_Scope;
757
758 -- If this is an entry family, remove the loop created to provide
759 -- a scope for the entry index.
760
761 if Ekind (Id) = E_Entry_Family
762 and then Present (Entry_Index_Specification (Formals))
763 then
764 End_Scope;
765 end if;
766
767 end Analyze_Entry_Body;
768
769 ------------------------------------
770 -- Analyze_Entry_Body_Formal_Part --
771 ------------------------------------
772
773 procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
774 Id : constant Entity_Id := Defining_Identifier (Parent (N));
775 Index : constant Node_Id := Entry_Index_Specification (N);
776 Formals : constant List_Id := Parameter_Specifications (N);
777
778 begin
779 Tasking_Used := True;
780
781 if Present (Index) then
782 Analyze (Index);
783 end if;
784
785 if Present (Formals) then
786 Set_Scope (Id, Current_Scope);
787 New_Scope (Id);
788 Process_Formals (Formals, Parent (N));
789 End_Scope;
790 end if;
791 end Analyze_Entry_Body_Formal_Part;
792
793 ------------------------------------
794 -- Analyze_Entry_Call_Alternative --
795 ------------------------------------
796
797 procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
798 Call : constant Node_Id := Entry_Call_Statement (N);
799
800 begin
801 Tasking_Used := True;
802
803 if Present (Pragmas_Before (N)) then
804 Analyze_List (Pragmas_Before (N));
805 end if;
806
807 if Nkind (Call) = N_Attribute_Reference then
808
809 -- Possibly a stream attribute, but definitely illegal. Other
810 -- illegalitles, such as procedure calls, are diagnosed after
811 -- resolution.
812
813 Error_Msg_N ("entry call alternative requires an entry call", Call);
814 return;
815 end if;
816
817 Analyze (Call);
818
819 if Is_Non_Empty_List (Statements (N)) then
820 Analyze_Statements (Statements (N));
821 end if;
822 end Analyze_Entry_Call_Alternative;
823
824 -------------------------------
825 -- Analyze_Entry_Declaration --
826 -------------------------------
827
828 procedure Analyze_Entry_Declaration (N : Node_Id) is
829 Formals : constant List_Id := Parameter_Specifications (N);
830 Id : constant Entity_Id := Defining_Identifier (N);
831 D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
832
833 begin
834 Generate_Definition (Id);
835 Tasking_Used := True;
836
837 if No (D_Sdef) then
838 Set_Ekind (Id, E_Entry);
839 else
840 Enter_Name (Id);
841 Set_Ekind (Id, E_Entry_Family);
842 Analyze (D_Sdef);
843 Make_Index (D_Sdef, N, Id);
844 end if;
845
846 Set_Etype (Id, Standard_Void_Type);
847 Set_Convention (Id, Convention_Entry);
848 Set_Accept_Address (Id, New_Elmt_List);
849
850 if Present (Formals) then
851 Set_Scope (Id, Current_Scope);
852 New_Scope (Id);
853 Process_Formals (Formals, N);
854 Create_Extra_Formals (Id);
855 End_Scope;
856 end if;
857
858 if Ekind (Id) = E_Entry then
859 New_Overloaded_Entity (Id);
860 end if;
861 end Analyze_Entry_Declaration;
862
863 ---------------------------------------
864 -- Analyze_Entry_Index_Specification --
865 ---------------------------------------
866
867 -- The defining_Identifier of the entry index specification is local
868 -- to the entry body, but must be available in the entry barrier,
869 -- which is evaluated outside of the entry body. The index is eventually
870 -- renamed as a run-time object, so is visibility is strictly a front-end
871 -- concern. In order to make it available to the barrier, we create
872 -- an additional scope, as for a loop, whose only declaration is the
873 -- index name. This loop is not attached to the tree and does not appear
874 -- as an entity local to the protected type, so its existence need only
875 -- be knwown to routines that process entry families.
876
877 procedure Analyze_Entry_Index_Specification (N : Node_Id) is
878 Iden : constant Node_Id := Defining_Identifier (N);
879 Def : constant Node_Id := Discrete_Subtype_Definition (N);
880 Loop_Id : constant Entity_Id :=
881 Make_Defining_Identifier (Sloc (N),
882 Chars => New_Internal_Name ('L'));
883
884 begin
885 Tasking_Used := True;
886 Analyze (Def);
887
888 -- There is no elaboration of the entry index specification. Therefore,
889 -- if the index is a range, it is not resolved and expanded, but the
890 -- bounds are inherited from the entry declaration, and reanalyzed.
891 -- See Analyze_Entry_Body.
892
893 if Nkind (Def) /= N_Range then
894 Make_Index (Def, N);
895 end if;
896
897 Set_Ekind (Loop_Id, E_Loop);
898 Set_Scope (Loop_Id, Current_Scope);
899 New_Scope (Loop_Id);
900 Enter_Name (Iden);
901 Set_Ekind (Iden, E_Entry_Index_Parameter);
902 Set_Etype (Iden, Etype (Def));
903 end Analyze_Entry_Index_Specification;
904
905 ----------------------------
906 -- Analyze_Protected_Body --
907 ----------------------------
908
909 procedure Analyze_Protected_Body (N : Node_Id) is
910 Body_Id : constant Entity_Id := Defining_Identifier (N);
911 Last_E : Entity_Id;
912
913 Spec_Id : Entity_Id;
914 -- This is initially the entity of the protected object or protected
915 -- type involved, but is replaced by the protected type always in the
916 -- case of a single protected declaration, since this is the proper
917 -- scope to be used.
918
919 Ref_Id : Entity_Id;
920 -- This is the entity of the protected object or protected type
921 -- involved, and is the entity used for cross-reference purposes
922 -- (it differs from Spec_Id in the case of a single protected
923 -- object, since Spec_Id is set to the protected type in this case).
924
925 begin
926 Tasking_Used := True;
927 Set_Ekind (Body_Id, E_Protected_Body);
928 Spec_Id := Find_Concurrent_Spec (Body_Id);
929
930 if Present (Spec_Id)
931 and then Ekind (Spec_Id) = E_Protected_Type
932 then
933 null;
934
935 elsif Present (Spec_Id)
936 and then Ekind (Etype (Spec_Id)) = E_Protected_Type
937 and then not Comes_From_Source (Etype (Spec_Id))
938 then
939 null;
940
941 else
942 Error_Msg_N ("missing specification for protected body", Body_Id);
943 return;
944 end if;
945
946 Ref_Id := Spec_Id;
947 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
948 Style.Check_Identifier (Body_Id, Spec_Id);
949
950 -- The declarations are always attached to the type
951
952 if Ekind (Spec_Id) /= E_Protected_Type then
953 Spec_Id := Etype (Spec_Id);
954 end if;
955
956 New_Scope (Spec_Id);
957 Set_Corresponding_Spec (N, Spec_Id);
958 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
959 Set_Has_Completion (Spec_Id);
960 Install_Declarations (Spec_Id);
961
962 Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id);
963
964 Last_E := Last_Entity (Spec_Id);
965
966 Analyze_Declarations (Declarations (N));
967
968 -- For visibility purposes, all entities in the body are private.
969 -- Set First_Private_Entity accordingly, if there was no private
970 -- part in the protected declaration.
971
972 if No (First_Private_Entity (Spec_Id)) then
973 if Present (Last_E) then
974 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
975 else
976 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
977 end if;
978 end if;
979
980 Check_Completion (Body_Id);
981 Check_References (Spec_Id);
982 Process_End_Label (N, 't', Ref_Id);
983 End_Scope;
984 end Analyze_Protected_Body;
985
986 ----------------------------------
987 -- Analyze_Protected_Definition --
988 ----------------------------------
989
990 procedure Analyze_Protected_Definition (N : Node_Id) is
991 E : Entity_Id;
992 L : Entity_Id;
993
994 begin
995 Tasking_Used := True;
996 Analyze_Declarations (Visible_Declarations (N));
997
998 if Present (Private_Declarations (N))
999 and then not Is_Empty_List (Private_Declarations (N))
1000 then
1001 L := Last_Entity (Current_Scope);
1002 Analyze_Declarations (Private_Declarations (N));
1003
1004 if Present (L) then
1005 Set_First_Private_Entity (Current_Scope, Next_Entity (L));
1006
1007 else
1008 Set_First_Private_Entity (Current_Scope,
1009 First_Entity (Current_Scope));
1010 end if;
1011 end if;
1012
1013 E := First_Entity (Current_Scope);
1014
1015 while Present (E) loop
1016
1017 if Ekind (E) = E_Function
1018 or else Ekind (E) = E_Procedure
1019 then
1020 Set_Convention (E, Convention_Protected);
1021
1022 elsif Is_Task_Type (Etype (E))
1023 or else Has_Task (Etype (E))
1024 then
1025 Set_Has_Task (Current_Scope);
1026 end if;
1027
1028 Next_Entity (E);
1029 end loop;
1030
1031 Check_Max_Entries (N, Max_Protected_Entries);
1032 Process_End_Label (N, 'e', Current_Scope);
1033 Check_Overriding_Indicator (N);
1034 end Analyze_Protected_Definition;
1035
1036 ----------------------------
1037 -- Analyze_Protected_Type --
1038 ----------------------------
1039
1040 procedure Analyze_Protected_Type (N : Node_Id) is
1041 E : Entity_Id;
1042 T : Entity_Id;
1043 Def_Id : constant Entity_Id := Defining_Identifier (N);
1044 Iface : Node_Id;
1045 Iface_Def : Node_Id;
1046 Iface_Typ : Entity_Id;
1047
1048 begin
1049 if No_Run_Time_Mode then
1050 Error_Msg_CRT ("protected type", N);
1051 return;
1052 end if;
1053
1054 Tasking_Used := True;
1055 Check_Restriction (No_Protected_Types, N);
1056
1057 T := Find_Type_Name (N);
1058
1059 if Ekind (T) = E_Incomplete_Type then
1060 T := Full_View (T);
1061 Set_Completion_Referenced (T);
1062 end if;
1063
1064 Set_Ekind (T, E_Protected_Type);
1065 Set_Is_First_Subtype (T, True);
1066 Init_Size_Align (T);
1067 Set_Etype (T, T);
1068 Set_Has_Delayed_Freeze (T, True);
1069 Set_Stored_Constraint (T, No_Elist);
1070 New_Scope (T);
1071
1072 -- Ada 2005 (AI-345)
1073
1074 if Present (Interface_List (N)) then
1075 Iface := First (Interface_List (N));
1076
1077 while Present (Iface) loop
1078 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
1079 Iface_Def := Type_Definition (Parent (Iface_Typ));
1080
1081 if not Is_Interface (Iface_Typ) then
1082 Error_Msg_NE ("(Ada 2005) & must be an interface",
1083 Iface, Iface_Typ);
1084
1085 else
1086 -- Ada 2005 (AI-251): "The declaration of a specific
1087 -- descendant of an interface type freezes the interface
1088 -- type" RM 13.14
1089
1090 Freeze_Before (N, Etype (Iface));
1091
1092 -- Ada 2005 (AI-345): Protected types can only implement
1093 -- limited, synchronized or protected interfaces.
1094
1095 if Limited_Present (Iface_Def)
1096 or else Synchronized_Present (Iface_Def)
1097 or else Protected_Present (Iface_Def)
1098 then
1099 null;
1100
1101 elsif Task_Present (Iface_Def) then
1102 Error_Msg_N ("(Ada 2005) protected type cannot implement a "
1103 & "task interface", Iface);
1104
1105 else
1106 Error_Msg_N ("(Ada 2005) protected type cannot implement a "
1107 & "non-limited interface", Iface);
1108 end if;
1109 end if;
1110
1111 Next (Iface);
1112 end loop;
1113 end if;
1114
1115 if Present (Discriminant_Specifications (N)) then
1116 if Has_Discriminants (T) then
1117
1118 -- Install discriminants. Also, verify conformance of
1119 -- discriminants of previous and current view. ???
1120
1121 Install_Declarations (T);
1122 else
1123 Process_Discriminants (N);
1124 end if;
1125 end if;
1126
1127 Set_Is_Constrained (T, not Has_Discriminants (T));
1128
1129 Analyze (Protected_Definition (N));
1130
1131 -- Protected types with entries are controlled (because of the
1132 -- Protection component if nothing else), same for any protected type
1133 -- with interrupt handlers. Note that we need to analyze the protected
1134 -- definition to set Has_Entries and such.
1135
1136 if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
1137 or else Number_Entries (T) > 1)
1138 and then
1139 (Has_Entries (T)
1140 or else Has_Interrupt_Handler (T)
1141 or else Has_Attach_Handler (T))
1142 then
1143 Set_Has_Controlled_Component (T, True);
1144 end if;
1145
1146 -- The Ekind of components is E_Void during analysis to detect
1147 -- illegal uses. Now it can be set correctly.
1148
1149 E := First_Entity (Current_Scope);
1150
1151 while Present (E) loop
1152 if Ekind (E) = E_Void then
1153 Set_Ekind (E, E_Component);
1154 Init_Component_Location (E);
1155 end if;
1156
1157 Next_Entity (E);
1158 end loop;
1159
1160 End_Scope;
1161
1162 if T /= Def_Id
1163 and then Is_Private_Type (Def_Id)
1164 and then Has_Discriminants (Def_Id)
1165 and then Expander_Active
1166 then
1167 Exp_Ch9.Expand_N_Protected_Type_Declaration (N);
1168 Process_Full_View (N, T, Def_Id);
1169 end if;
1170 end Analyze_Protected_Type;
1171
1172 ---------------------
1173 -- Analyze_Requeue --
1174 ---------------------
1175
1176 procedure Analyze_Requeue (N : Node_Id) is
1177 Count : Natural := 0;
1178 Entry_Name : Node_Id := Name (N);
1179 Entry_Id : Entity_Id;
1180 I : Interp_Index;
1181 It : Interp;
1182 Enclosing : Entity_Id;
1183 Target_Obj : Node_Id := Empty;
1184 Req_Scope : Entity_Id;
1185 Outer_Ent : Entity_Id;
1186
1187 begin
1188 Check_Restriction (No_Requeue_Statements, N);
1189 Check_Unreachable_Code (N);
1190 Tasking_Used := True;
1191
1192 Enclosing := Empty;
1193 for J in reverse 0 .. Scope_Stack.Last loop
1194 Enclosing := Scope_Stack.Table (J).Entity;
1195 exit when Is_Entry (Enclosing);
1196
1197 if Ekind (Enclosing) /= E_Block
1198 and then Ekind (Enclosing) /= E_Loop
1199 then
1200 Error_Msg_N ("requeue must appear within accept or entry body", N);
1201 return;
1202 end if;
1203 end loop;
1204
1205 Analyze (Entry_Name);
1206
1207 if Etype (Entry_Name) = Any_Type then
1208 return;
1209 end if;
1210
1211 if Nkind (Entry_Name) = N_Selected_Component then
1212 Target_Obj := Prefix (Entry_Name);
1213 Entry_Name := Selector_Name (Entry_Name);
1214 end if;
1215
1216 -- If an explicit target object is given then we have to check
1217 -- the restrictions of 9.5.4(6).
1218
1219 if Present (Target_Obj) then
1220
1221 -- Locate containing concurrent unit and determine enclosing entry
1222 -- body or outermost enclosing accept statement within the unit.
1223
1224 Outer_Ent := Empty;
1225 for S in reverse 0 .. Scope_Stack.Last loop
1226 Req_Scope := Scope_Stack.Table (S).Entity;
1227
1228 exit when Ekind (Req_Scope) in Task_Kind
1229 or else Ekind (Req_Scope) in Protected_Kind;
1230
1231 if Is_Entry (Req_Scope) then
1232 Outer_Ent := Req_Scope;
1233 end if;
1234 end loop;
1235
1236 pragma Assert (Present (Outer_Ent));
1237
1238 -- Check that the accessibility level of the target object
1239 -- is not greater or equal to the outermost enclosing accept
1240 -- statement (or entry body) unless it is a parameter of the
1241 -- innermost enclosing accept statement (or entry body).
1242
1243 if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
1244 and then
1245 (not Is_Entity_Name (Target_Obj)
1246 or else Ekind (Entity (Target_Obj)) not in Formal_Kind
1247 or else Enclosing /= Scope (Entity (Target_Obj)))
1248 then
1249 Error_Msg_N
1250 ("target object has invalid level for requeue", Target_Obj);
1251 end if;
1252 end if;
1253
1254 -- Overloaded case, find right interpretation
1255
1256 if Is_Overloaded (Entry_Name) then
1257 Get_First_Interp (Entry_Name, I, It);
1258 Entry_Id := Empty;
1259
1260 while Present (It.Nam) loop
1261 if No (First_Formal (It.Nam))
1262 or else Subtype_Conformant (Enclosing, It.Nam)
1263 then
1264
1265 -- Ada 2005 (AI-345): Since protected and task types have
1266 -- primitive entry wrappers, we only consider source entries.
1267
1268 if Comes_From_Source (It.Nam) then
1269 Count := Count + 1;
1270 Entry_Id := It.Nam;
1271 else
1272 Remove_Interp (I);
1273 end if;
1274 end if;
1275
1276 Get_Next_Interp (I, It);
1277 end loop;
1278
1279 if Count = 0 then
1280 Error_Msg_N ("no entry matches context", N);
1281 return;
1282
1283 elsif Count > 1 then
1284 Error_Msg_N ("ambiguous entry name in requeue", N);
1285 return;
1286
1287 else
1288 Set_Is_Overloaded (Entry_Name, False);
1289 Set_Entity (Entry_Name, Entry_Id);
1290 end if;
1291
1292 -- Non-overloaded cases
1293
1294 -- For the case of a reference to an element of an entry family,
1295 -- the Entry_Name is an indexed component.
1296
1297 elsif Nkind (Entry_Name) = N_Indexed_Component then
1298
1299 -- Requeue to an entry out of the body
1300
1301 if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
1302 Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
1303
1304 -- Requeue from within the body itself
1305
1306 elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
1307 Entry_Id := Entity (Prefix (Entry_Name));
1308
1309 else
1310 Error_Msg_N ("invalid entry_name specified", N);
1311 return;
1312 end if;
1313
1314 -- If we had a requeue of the form REQUEUE A (B), then the parser
1315 -- accepted it (because it could have been a requeue on an entry
1316 -- index. If A turns out not to be an entry family, then the analysis
1317 -- of A (B) turned it into a function call.
1318
1319 elsif Nkind (Entry_Name) = N_Function_Call then
1320 Error_Msg_N
1321 ("arguments not allowed in requeue statement",
1322 First (Parameter_Associations (Entry_Name)));
1323 return;
1324
1325 -- Normal case of no entry family, no argument
1326
1327 else
1328 Entry_Id := Entity (Entry_Name);
1329 end if;
1330
1331 -- Resolve entry, and check that it is subtype conformant with the
1332 -- enclosing construct if this construct has formals (RM 9.5.4(5)).
1333
1334 if not Is_Entry (Entry_Id) then
1335 Error_Msg_N ("expect entry name in requeue statement", Name (N));
1336 elsif Ekind (Entry_Id) = E_Entry_Family
1337 and then Nkind (Entry_Name) /= N_Indexed_Component
1338 then
1339 Error_Msg_N ("missing index for entry family component", Name (N));
1340
1341 else
1342 Resolve_Entry (Name (N));
1343 Generate_Reference (Entry_Id, Entry_Name);
1344
1345 if Present (First_Formal (Entry_Id)) then
1346 Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
1347
1348 -- Processing for parameters accessed by the requeue
1349
1350 declare
1351 Ent : Entity_Id := First_Formal (Enclosing);
1352
1353 begin
1354 while Present (Ent) loop
1355
1356 -- For OUT or IN OUT parameter, the effect of the requeue
1357 -- is to assign the parameter a value on exit from the
1358 -- requeued body, so we can set it as source assigned.
1359 -- We also clear the Is_True_Constant indication. We do
1360 -- not need to clear Current_Value, since the effect of
1361 -- the requeue is to perform an unconditional goto so
1362 -- that any further references will not occur anyway.
1363
1364 if Ekind (Ent) = E_Out_Parameter
1365 or else
1366 Ekind (Ent) = E_In_Out_Parameter
1367 then
1368 Set_Never_Set_In_Source (Ent, False);
1369 Set_Is_True_Constant (Ent, False);
1370 end if;
1371
1372 -- For all parameters, the requeue acts as a reference,
1373 -- since the value of the parameter is passed to the
1374 -- new entry, so we want to suppress unreferenced warnings.
1375
1376 Set_Referenced (Ent);
1377 Next_Formal (Ent);
1378 end loop;
1379 end;
1380 end if;
1381 end if;
1382 end Analyze_Requeue;
1383
1384 ------------------------------
1385 -- Analyze_Selective_Accept --
1386 ------------------------------
1387
1388 procedure Analyze_Selective_Accept (N : Node_Id) is
1389 Alts : constant List_Id := Select_Alternatives (N);
1390 Alt : Node_Id;
1391
1392 Accept_Present : Boolean := False;
1393 Terminate_Present : Boolean := False;
1394 Delay_Present : Boolean := False;
1395 Relative_Present : Boolean := False;
1396 Alt_Count : Uint := Uint_0;
1397
1398 begin
1399 Check_Restriction (No_Select_Statements, N);
1400 Tasking_Used := True;
1401
1402 Alt := First (Alts);
1403 while Present (Alt) loop
1404 Alt_Count := Alt_Count + 1;
1405 Analyze (Alt);
1406
1407 if Nkind (Alt) = N_Delay_Alternative then
1408 if Delay_Present then
1409
1410 if Relative_Present /=
1411 (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
1412 then
1413 Error_Msg_N
1414 ("delay_until and delay_relative alternatives ", Alt);
1415 Error_Msg_N
1416 ("\cannot appear in the same selective_wait", Alt);
1417 end if;
1418
1419 else
1420 Delay_Present := True;
1421 Relative_Present :=
1422 Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
1423 end if;
1424
1425 elsif Nkind (Alt) = N_Terminate_Alternative then
1426 if Terminate_Present then
1427 Error_Msg_N ("only one terminate alternative allowed", N);
1428 else
1429 Terminate_Present := True;
1430 Check_Restriction (No_Terminate_Alternatives, N);
1431 end if;
1432
1433 elsif Nkind (Alt) = N_Accept_Alternative then
1434 Accept_Present := True;
1435
1436 -- Check for duplicate accept
1437
1438 declare
1439 Alt1 : Node_Id;
1440 Stm : constant Node_Id := Accept_Statement (Alt);
1441 EDN : constant Node_Id := Entry_Direct_Name (Stm);
1442 Ent : Entity_Id;
1443
1444 begin
1445 if Nkind (EDN) = N_Identifier
1446 and then No (Condition (Alt))
1447 and then Present (Entity (EDN)) -- defend against junk
1448 and then Ekind (Entity (EDN)) = E_Entry
1449 then
1450 Ent := Entity (EDN);
1451
1452 Alt1 := First (Alts);
1453 while Alt1 /= Alt loop
1454 if Nkind (Alt1) = N_Accept_Alternative
1455 and then No (Condition (Alt1))
1456 then
1457 declare
1458 Stm1 : constant Node_Id := Accept_Statement (Alt1);
1459 EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
1460
1461 begin
1462 if Nkind (EDN1) = N_Identifier then
1463 if Entity (EDN1) = Ent then
1464 Error_Msg_Sloc := Sloc (Stm1);
1465 Error_Msg_N
1466 ("?accept duplicates one on line#", Stm);
1467 exit;
1468 end if;
1469 end if;
1470 end;
1471 end if;
1472
1473 Next (Alt1);
1474 end loop;
1475 end if;
1476 end;
1477 end if;
1478
1479 Next (Alt);
1480 end loop;
1481
1482 Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
1483 Check_Potentially_Blocking_Operation (N);
1484
1485 if Terminate_Present and Delay_Present then
1486 Error_Msg_N ("at most one of terminate or delay alternative", N);
1487
1488 elsif not Accept_Present then
1489 Error_Msg_N
1490 ("select must contain at least one accept alternative", N);
1491 end if;
1492
1493 if Present (Else_Statements (N)) then
1494 if Terminate_Present or Delay_Present then
1495 Error_Msg_N ("else part not allowed with other alternatives", N);
1496 end if;
1497
1498 Analyze_Statements (Else_Statements (N));
1499 end if;
1500 end Analyze_Selective_Accept;
1501
1502 ------------------------------
1503 -- Analyze_Single_Protected --
1504 ------------------------------
1505
1506 procedure Analyze_Single_Protected (N : Node_Id) is
1507 Loc : constant Source_Ptr := Sloc (N);
1508 Id : constant Node_Id := Defining_Identifier (N);
1509 T : Entity_Id;
1510 T_Decl : Node_Id;
1511 O_Decl : Node_Id;
1512 O_Name : constant Entity_Id := New_Copy (Id);
1513
1514 begin
1515 Generate_Definition (Id);
1516 Tasking_Used := True;
1517
1518 -- The node is rewritten as a protected type declaration,
1519 -- in exact analogy with what is done with single tasks.
1520
1521 T :=
1522 Make_Defining_Identifier (Sloc (Id),
1523 New_External_Name (Chars (Id), 'T'));
1524
1525 T_Decl :=
1526 Make_Protected_Type_Declaration (Loc,
1527 Defining_Identifier => T,
1528 Protected_Definition => Relocate_Node (Protected_Definition (N)),
1529 Interface_List => Interface_List (N));
1530
1531 -- Ada 2005 (AI-399): Mark the object as aliased. Required to use
1532 -- the attribute 'access
1533
1534 O_Decl :=
1535 Make_Object_Declaration (Loc,
1536 Defining_Identifier => O_Name,
1537 Aliased_Present => Ada_Version >= Ada_05,
1538 Object_Definition => Make_Identifier (Loc, Chars (T)));
1539
1540 Rewrite (N, T_Decl);
1541 Insert_After (N, O_Decl);
1542 Mark_Rewrite_Insertion (O_Decl);
1543
1544 -- Enter names of type and object before analysis, because the name
1545 -- of the object may be used in its own body.
1546
1547 Enter_Name (T);
1548 Set_Ekind (T, E_Protected_Type);
1549 Set_Etype (T, T);
1550
1551 Enter_Name (O_Name);
1552 Set_Ekind (O_Name, E_Variable);
1553 Set_Etype (O_Name, T);
1554
1555 -- Instead of calling Analyze on the new node, call directly
1556 -- the proper analysis procedure. Otherwise the node would be
1557 -- expanded twice, with disastrous result.
1558
1559 Analyze_Protected_Type (N);
1560 end Analyze_Single_Protected;
1561
1562 -------------------------
1563 -- Analyze_Single_Task --
1564 -------------------------
1565
1566 procedure Analyze_Single_Task (N : Node_Id) is
1567 Loc : constant Source_Ptr := Sloc (N);
1568 Id : constant Node_Id := Defining_Identifier (N);
1569 T : Entity_Id;
1570 T_Decl : Node_Id;
1571 O_Decl : Node_Id;
1572 O_Name : constant Entity_Id := New_Copy (Id);
1573
1574 begin
1575 Generate_Definition (Id);
1576 Tasking_Used := True;
1577
1578 -- The node is rewritten as a task type declaration, followed
1579 -- by an object declaration of that anonymous task type.
1580
1581 T :=
1582 Make_Defining_Identifier (Sloc (Id),
1583 New_External_Name (Chars (Id), Suffix => "TK"));
1584
1585 T_Decl :=
1586 Make_Task_Type_Declaration (Loc,
1587 Defining_Identifier => T,
1588 Task_Definition => Relocate_Node (Task_Definition (N)),
1589 Interface_List => Interface_List (N));
1590
1591 -- Ada 2005 (AI-399): Mark the object as aliased. Required to use
1592 -- the attribute 'access
1593
1594 O_Decl :=
1595 Make_Object_Declaration (Loc,
1596 Defining_Identifier => O_Name,
1597 Aliased_Present => Ada_Version >= Ada_05,
1598 Object_Definition => Make_Identifier (Loc, Chars (T)));
1599
1600 Rewrite (N, T_Decl);
1601 Insert_After (N, O_Decl);
1602 Mark_Rewrite_Insertion (O_Decl);
1603
1604 -- Enter names of type and object before analysis, because the name
1605 -- of the object may be used in its own body.
1606
1607 Enter_Name (T);
1608 Set_Ekind (T, E_Task_Type);
1609 Set_Etype (T, T);
1610
1611 Enter_Name (O_Name);
1612 Set_Ekind (O_Name, E_Variable);
1613 Set_Etype (O_Name, T);
1614
1615 -- Instead of calling Analyze on the new node, call directly
1616 -- the proper analysis procedure. Otherwise the node would be
1617 -- expanded twice, with disastrous result.
1618
1619 Analyze_Task_Type (N);
1620 end Analyze_Single_Task;
1621
1622 -----------------------
1623 -- Analyze_Task_Body --
1624 -----------------------
1625
1626 procedure Analyze_Task_Body (N : Node_Id) is
1627 Body_Id : constant Entity_Id := Defining_Identifier (N);
1628 Last_E : Entity_Id;
1629
1630 Spec_Id : Entity_Id;
1631 -- This is initially the entity of the task or task type involved,
1632 -- but is replaced by the task type always in the case of a single
1633 -- task declaration, since this is the proper scope to be used.
1634
1635 Ref_Id : Entity_Id;
1636 -- This is the entity of the task or task type, and is the entity
1637 -- used for cross-reference purposes (it differs from Spec_Id in
1638 -- the case of a single task, since Spec_Id is set to the task type)
1639
1640 begin
1641 Tasking_Used := True;
1642 Set_Ekind (Body_Id, E_Task_Body);
1643 Set_Scope (Body_Id, Current_Scope);
1644 Spec_Id := Find_Concurrent_Spec (Body_Id);
1645
1646 -- The spec is either a task type declaration, or a single task
1647 -- declaration for which we have created an anonymous type.
1648
1649 if Present (Spec_Id)
1650 and then Ekind (Spec_Id) = E_Task_Type
1651 then
1652 null;
1653
1654 elsif Present (Spec_Id)
1655 and then Ekind (Etype (Spec_Id)) = E_Task_Type
1656 and then not Comes_From_Source (Etype (Spec_Id))
1657 then
1658 null;
1659
1660 else
1661 Error_Msg_N ("missing specification for task body", Body_Id);
1662 return;
1663 end if;
1664
1665 if Has_Completion (Spec_Id)
1666 and then Present (Corresponding_Body (Parent (Spec_Id)))
1667 then
1668 if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
1669 Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
1670
1671 else
1672 Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
1673 end if;
1674 end if;
1675
1676 Ref_Id := Spec_Id;
1677 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1678 Style.Check_Identifier (Body_Id, Spec_Id);
1679
1680 -- Deal with case of body of single task (anonymous type was created)
1681
1682 if Ekind (Spec_Id) = E_Variable then
1683 Spec_Id := Etype (Spec_Id);
1684 end if;
1685
1686 New_Scope (Spec_Id);
1687 Set_Corresponding_Spec (N, Spec_Id);
1688 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1689 Set_Has_Completion (Spec_Id);
1690 Install_Declarations (Spec_Id);
1691 Last_E := Last_Entity (Spec_Id);
1692
1693 Analyze_Declarations (Declarations (N));
1694
1695 -- For visibility purposes, all entities in the body are private.
1696 -- Set First_Private_Entity accordingly, if there was no private
1697 -- part in the protected declaration.
1698
1699 if No (First_Private_Entity (Spec_Id)) then
1700 if Present (Last_E) then
1701 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1702 else
1703 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1704 end if;
1705 end if;
1706
1707 Analyze (Handled_Statement_Sequence (N));
1708 Check_Completion (Body_Id);
1709 Check_References (Body_Id);
1710 Check_References (Spec_Id);
1711
1712 -- Check for entries with no corresponding accept
1713
1714 declare
1715 Ent : Entity_Id;
1716
1717 begin
1718 Ent := First_Entity (Spec_Id);
1719
1720 while Present (Ent) loop
1721 if Is_Entry (Ent)
1722 and then not Entry_Accepted (Ent)
1723 and then Comes_From_Source (Ent)
1724 then
1725 Error_Msg_NE ("no accept for entry &?", N, Ent);
1726 end if;
1727
1728 Next_Entity (Ent);
1729 end loop;
1730 end;
1731
1732 Process_End_Label (Handled_Statement_Sequence (N), 't', Ref_Id);
1733 End_Scope;
1734 end Analyze_Task_Body;
1735
1736 -----------------------------
1737 -- Analyze_Task_Definition --
1738 -----------------------------
1739
1740 procedure Analyze_Task_Definition (N : Node_Id) is
1741 L : Entity_Id;
1742
1743 begin
1744 Tasking_Used := True;
1745
1746 if Present (Visible_Declarations (N)) then
1747 Analyze_Declarations (Visible_Declarations (N));
1748 end if;
1749
1750 if Present (Private_Declarations (N)) then
1751 L := Last_Entity (Current_Scope);
1752 Analyze_Declarations (Private_Declarations (N));
1753
1754 if Present (L) then
1755 Set_First_Private_Entity
1756 (Current_Scope, Next_Entity (L));
1757 else
1758 Set_First_Private_Entity
1759 (Current_Scope, First_Entity (Current_Scope));
1760 end if;
1761 end if;
1762
1763 Check_Max_Entries (N, Max_Task_Entries);
1764 Process_End_Label (N, 'e', Current_Scope);
1765 Check_Overriding_Indicator (N);
1766 end Analyze_Task_Definition;
1767
1768 -----------------------
1769 -- Analyze_Task_Type --
1770 -----------------------
1771
1772 procedure Analyze_Task_Type (N : Node_Id) is
1773 T : Entity_Id;
1774 Def_Id : constant Entity_Id := Defining_Identifier (N);
1775 Iface : Node_Id;
1776 Iface_Def : Node_Id;
1777 Iface_Typ : Entity_Id;
1778
1779 begin
1780 Check_Restriction (No_Tasking, N);
1781 Tasking_Used := True;
1782 T := Find_Type_Name (N);
1783 Generate_Definition (T);
1784
1785 if Ekind (T) = E_Incomplete_Type then
1786 T := Full_View (T);
1787 Set_Completion_Referenced (T);
1788 end if;
1789
1790 Set_Ekind (T, E_Task_Type);
1791 Set_Is_First_Subtype (T, True);
1792 Set_Has_Task (T, True);
1793 Init_Size_Align (T);
1794 Set_Etype (T, T);
1795 Set_Has_Delayed_Freeze (T, True);
1796 Set_Stored_Constraint (T, No_Elist);
1797 New_Scope (T);
1798
1799 -- Ada 2005 (AI-345)
1800
1801 if Present (Interface_List (N)) then
1802 Iface := First (Interface_List (N));
1803 while Present (Iface) loop
1804 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
1805 Iface_Def := Type_Definition (Parent (Iface_Typ));
1806
1807 if not Is_Interface (Iface_Typ) then
1808 Error_Msg_NE ("(Ada 2005) & must be an interface",
1809 Iface, Iface_Typ);
1810
1811 else
1812 -- Ada 2005 (AI-251): The declaration of a specific descendant
1813 -- of an interface type freezes the interface type (RM 13.14).
1814
1815 Freeze_Before (N, Etype (Iface));
1816
1817 -- Ada 2005 (AI-345): Task types can only implement limited,
1818 -- synchronized or task interfaces.
1819
1820 if Limited_Present (Iface_Def)
1821 or else Synchronized_Present (Iface_Def)
1822 or else Task_Present (Iface_Def)
1823 then
1824 null;
1825
1826 elsif Protected_Present (Iface_Def) then
1827 Error_Msg_N ("(Ada 2005) task type cannot implement a " &
1828 "protected interface", Iface);
1829
1830 else
1831 Error_Msg_N ("(Ada 2005) task type cannot implement a " &
1832 "non-limited interface", Iface);
1833 end if;
1834 end if;
1835
1836 Next (Iface);
1837 end loop;
1838 end if;
1839
1840 if Present (Discriminant_Specifications (N)) then
1841 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
1842 Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
1843 end if;
1844
1845 if Has_Discriminants (T) then
1846
1847 -- Install discriminants. Also, verify conformance of
1848 -- discriminants of previous and current view. ???
1849
1850 Install_Declarations (T);
1851 else
1852 Process_Discriminants (N);
1853 end if;
1854 end if;
1855
1856 Set_Is_Constrained (T, not Has_Discriminants (T));
1857
1858 if Present (Task_Definition (N)) then
1859 Analyze_Task_Definition (Task_Definition (N));
1860 end if;
1861
1862 if not Is_Library_Level_Entity (T) then
1863 Check_Restriction (No_Task_Hierarchy, N);
1864 end if;
1865
1866 End_Scope;
1867
1868 if T /= Def_Id
1869 and then Is_Private_Type (Def_Id)
1870 and then Has_Discriminants (Def_Id)
1871 and then Expander_Active
1872 then
1873 Exp_Ch9.Expand_N_Task_Type_Declaration (N);
1874 Process_Full_View (N, T, Def_Id);
1875 end if;
1876 end Analyze_Task_Type;
1877
1878 -----------------------------------
1879 -- Analyze_Terminate_Alternative --
1880 -----------------------------------
1881
1882 procedure Analyze_Terminate_Alternative (N : Node_Id) is
1883 begin
1884 Tasking_Used := True;
1885
1886 if Present (Pragmas_Before (N)) then
1887 Analyze_List (Pragmas_Before (N));
1888 end if;
1889
1890 if Present (Condition (N)) then
1891 Analyze_And_Resolve (Condition (N), Any_Boolean);
1892 end if;
1893 end Analyze_Terminate_Alternative;
1894
1895 ------------------------------
1896 -- Analyze_Timed_Entry_Call --
1897 ------------------------------
1898
1899 procedure Analyze_Timed_Entry_Call (N : Node_Id) is
1900 begin
1901 Check_Restriction (No_Select_Statements, N);
1902 Tasking_Used := True;
1903 Analyze (Entry_Call_Alternative (N));
1904 Analyze (Delay_Alternative (N));
1905 end Analyze_Timed_Entry_Call;
1906
1907 ------------------------------------
1908 -- Analyze_Triggering_Alternative --
1909 ------------------------------------
1910
1911 procedure Analyze_Triggering_Alternative (N : Node_Id) is
1912 Trigger : constant Node_Id := Triggering_Statement (N);
1913
1914 begin
1915 Tasking_Used := True;
1916
1917 if Present (Pragmas_Before (N)) then
1918 Analyze_List (Pragmas_Before (N));
1919 end if;
1920
1921 Analyze (Trigger);
1922 if Comes_From_Source (Trigger)
1923 and then Nkind (Trigger) /= N_Delay_Until_Statement
1924 and then Nkind (Trigger) /= N_Delay_Relative_Statement
1925 and then Nkind (Trigger) /= N_Entry_Call_Statement
1926 then
1927 if Ada_Version < Ada_05 then
1928 Error_Msg_N
1929 ("triggering statement must be delay or entry call", Trigger);
1930
1931 -- Ada 2005 (AI-345): If a procedure_call_statement is used
1932 -- for a procedure_or_entry_call, the procedure_name or pro-
1933 -- cedure_prefix of the procedure_call_statement shall denote
1934 -- an entry renamed by a procedure, or (a view of) a primitive
1935 -- subprogram of a limited interface whose first parameter is
1936 -- a controlling parameter.
1937
1938 elsif Nkind (Trigger) = N_Procedure_Call_Statement
1939 and then not Is_Renamed_Entry (Entity (Name (Trigger)))
1940 and then not Is_Controlling_Limited_Procedure
1941 (Entity (Name (Trigger)))
1942 then
1943 Error_Msg_N ("triggering statement must be delay, procedure " &
1944 "or entry call", Trigger);
1945 end if;
1946 end if;
1947
1948 if Is_Non_Empty_List (Statements (N)) then
1949 Analyze_Statements (Statements (N));
1950 end if;
1951 end Analyze_Triggering_Alternative;
1952
1953 -----------------------
1954 -- Check_Max_Entries --
1955 -----------------------
1956
1957 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
1958 Ecount : Uint;
1959
1960 procedure Count (L : List_Id);
1961 -- Count entries in given declaration list
1962
1963 -----------
1964 -- Count --
1965 -----------
1966
1967 procedure Count (L : List_Id) is
1968 D : Node_Id;
1969
1970 begin
1971 if No (L) then
1972 return;
1973 end if;
1974
1975 D := First (L);
1976 while Present (D) loop
1977 if Nkind (D) = N_Entry_Declaration then
1978 declare
1979 DSD : constant Node_Id :=
1980 Discrete_Subtype_Definition (D);
1981
1982 begin
1983 -- If not an entry family, then just one entry
1984
1985 if No (DSD) then
1986 Ecount := Ecount + 1;
1987
1988 -- If entry family with static bounds, count entries
1989
1990 elsif Is_OK_Static_Subtype (Etype (DSD)) then
1991 declare
1992 Lo : constant Uint :=
1993 Expr_Value
1994 (Type_Low_Bound (Etype (DSD)));
1995 Hi : constant Uint :=
1996 Expr_Value
1997 (Type_High_Bound (Etype (DSD)));
1998
1999 begin
2000 if Hi >= Lo then
2001 Ecount := Ecount + Hi - Lo + 1;
2002 end if;
2003 end;
2004
2005 -- Entry family with non-static bounds
2006
2007 else
2008 -- If restriction is set, then this is an error
2009
2010 if Restrictions.Set (R) then
2011 Error_Msg_N
2012 ("static subtype required by Restriction pragma",
2013 DSD);
2014
2015 -- Otherwise we record an unknown count restriction
2016
2017 else
2018 Check_Restriction (R, D);
2019 end if;
2020 end if;
2021 end;
2022 end if;
2023
2024 Next (D);
2025 end loop;
2026 end Count;
2027
2028 -- Start of processing for Check_Max_Entries
2029
2030 begin
2031 Ecount := Uint_0;
2032 Count (Visible_Declarations (D));
2033 Count (Private_Declarations (D));
2034
2035 if Ecount > 0 then
2036 Check_Restriction (R, D, Ecount);
2037 end if;
2038 end Check_Max_Entries;
2039
2040 --------------------------------
2041 -- Check_Overriding_Indicator --
2042 --------------------------------
2043
2044 procedure Check_Overriding_Indicator (Def : Node_Id) is
2045 Aliased_Hom : Entity_Id;
2046 Decl : Node_Id;
2047 Def_Id : Entity_Id;
2048 Hom : Entity_Id;
2049 Ifaces : constant List_Id := Interface_List (Parent (Def));
2050 Overrides : Boolean;
2051 Spec : Node_Id;
2052 Vis_Decls : constant List_Id := Visible_Declarations (Def);
2053
2054 function Matches_Prefixed_View_Profile
2055 (Ifaces : List_Id;
2056 Entry_Params : List_Id;
2057 Proc_Params : List_Id) return Boolean;
2058 -- Ada 2005 (AI-397): Determine if an entry parameter profile matches
2059 -- the prefixed view profile of an abstract procedure. Also determine
2060 -- whether the abstract procedure belongs to an implemented interface.
2061
2062 -----------------------------------
2063 -- Matches_Prefixed_View_Profile --
2064 -----------------------------------
2065
2066 function Matches_Prefixed_View_Profile
2067 (Ifaces : List_Id;
2068 Entry_Params : List_Id;
2069 Proc_Params : List_Id) return Boolean
2070 is
2071 Entry_Param : Node_Id;
2072 Proc_Param : Node_Id;
2073 Proc_Param_Typ : Entity_Id;
2074
2075 function Includes_Interface
2076 (Iface : Entity_Id;
2077 Ifaces : List_Id) return Boolean;
2078 -- Determine if an interface is contained in a list of interfaces
2079
2080 ------------------------
2081 -- Includes_Interface --
2082 ------------------------
2083
2084 function Includes_Interface
2085 (Iface : Entity_Id;
2086 Ifaces : List_Id) return Boolean
2087 is
2088 Ent : Entity_Id;
2089
2090 begin
2091 Ent := First (Ifaces);
2092
2093 while Present (Ent) loop
2094 if Etype (Ent) = Iface then
2095 return True;
2096 end if;
2097
2098 Next (Ent);
2099 end loop;
2100
2101 return False;
2102 end Includes_Interface;
2103
2104 -- Start of processing for Matches_Prefixed_View_Profile
2105
2106 begin
2107 Proc_Param := First (Proc_Params);
2108 Proc_Param_Typ := Etype (Parameter_Type (Proc_Param));
2109
2110 -- The first parameter of the abstract procedure must be of an
2111 -- interface type. The task or protected type must also implement
2112 -- that interface.
2113
2114 if not Is_Interface (Proc_Param_Typ)
2115 or else not Includes_Interface (Proc_Param_Typ, Ifaces)
2116 then
2117 return False;
2118 end if;
2119
2120 Entry_Param := First (Entry_Params);
2121 Proc_Param := Next (Proc_Param);
2122 while Present (Entry_Param)
2123 and then Present (Proc_Param)
2124 loop
2125 -- The two parameters must be mode conformant and have the exact
2126 -- same types.
2127
2128 if In_Present (Entry_Param) /= In_Present (Proc_Param)
2129 or else Out_Present (Entry_Param) /= Out_Present (Proc_Param)
2130 or else Etype (Parameter_Type (Entry_Param)) /=
2131 Etype (Parameter_Type (Proc_Param))
2132 then
2133 return False;
2134 end if;
2135
2136 Next (Entry_Param);
2137 Next (Proc_Param);
2138 end loop;
2139
2140 -- One of the lists is longer than the other
2141
2142 if Present (Entry_Param) or else Present (Proc_Param) then
2143 return False;
2144 end if;
2145
2146 return True;
2147 end Matches_Prefixed_View_Profile;
2148
2149 -- Start of processing for Check_Overriding_Indicator
2150
2151 begin
2152 if Present (Ifaces) then
2153 Decl := First (Vis_Decls);
2154 while Present (Decl) loop
2155
2156 -- Consider entries with either "overriding" or "not overriding"
2157 -- indicator present.
2158
2159 if Nkind (Decl) = N_Entry_Declaration
2160 and then (Must_Override (Decl)
2161 or else
2162 Must_Not_Override (Decl))
2163 then
2164 Def_Id := Defining_Identifier (Decl);
2165
2166 Overrides := False;
2167
2168 Hom := Homonym (Def_Id);
2169 while Present (Hom) loop
2170
2171 -- The current entry may override a procedure from an
2172 -- implemented interface.
2173
2174 if Ekind (Hom) = E_Procedure
2175 and then (Is_Abstract (Hom)
2176 or else
2177 Null_Present (Parent (Hom)))
2178 then
2179 Aliased_Hom := Hom;
2180
2181 while Present (Alias (Aliased_Hom)) loop
2182 Aliased_Hom := Alias (Aliased_Hom);
2183 end loop;
2184
2185 if Matches_Prefixed_View_Profile (Ifaces,
2186 Parameter_Specifications (Decl),
2187 Parameter_Specifications (Parent (Aliased_Hom)))
2188 then
2189 Overrides := True;
2190 exit;
2191 end if;
2192 end if;
2193
2194 Hom := Homonym (Hom);
2195 end loop;
2196
2197 if Overrides then
2198 if Must_Not_Override (Decl) then
2199 Error_Msg_NE ("entry& is overriding", Def_Id, Def_Id);
2200 end if;
2201 else
2202 if Must_Override (Decl) then
2203 Error_Msg_NE ("entry& is not overriding", Def_Id, Def_Id);
2204 end if;
2205 end if;
2206
2207 -- Consider subprograms with either "overriding" or "not
2208 -- overriding" indicator present.
2209
2210 elsif Nkind (Decl) = N_Subprogram_Declaration
2211 and then (Must_Override (Specification (Decl))
2212 or else
2213 Must_Not_Override (Specification (Decl)))
2214 then
2215 Spec := Specification (Decl);
2216 Def_Id := Defining_Unit_Name (Spec);
2217
2218 Overrides := False;
2219
2220 Hom := Homonym (Def_Id);
2221 while Present (Hom) loop
2222
2223 -- Function
2224
2225 if Ekind (Def_Id) = E_Function
2226 and then Ekind (Hom) = E_Function
2227 and then Is_Abstract (Hom)
2228 and then Matches_Prefixed_View_Profile (Ifaces,
2229 Parameter_Specifications (Spec),
2230 Parameter_Specifications (Parent (Hom)))
2231 and then Etype (Result_Definition (Spec)) =
2232 Etype (Result_Definition (Parent (Hom)))
2233 then
2234 Overrides := True;
2235 exit;
2236
2237 -- Procedure
2238
2239 elsif Ekind (Def_Id) = E_Procedure
2240 and then Ekind (Hom) = E_Procedure
2241 and then (Is_Abstract (Hom)
2242 or else
2243 Null_Present (Parent (Hom)))
2244 and then Matches_Prefixed_View_Profile (Ifaces,
2245 Parameter_Specifications (Spec),
2246 Parameter_Specifications (Parent (Hom)))
2247 then
2248 Overrides := True;
2249 exit;
2250 end if;
2251
2252 Hom := Homonym (Hom);
2253 end loop;
2254
2255 if Overrides then
2256 if Must_Not_Override (Spec) then
2257 Error_Msg_NE
2258 ("subprogram& is overriding", Def_Id, Def_Id);
2259 end if;
2260 else
2261 if Must_Override (Spec) then
2262 Error_Msg_NE
2263 ("subprogram& is not overriding", Def_Id, Def_Id);
2264 end if;
2265 end if;
2266 end if;
2267
2268 Next (Decl);
2269 end loop;
2270
2271 -- The protected or task type is not implementing an interface,
2272 -- we need to check for the presence of "overriding" entries or
2273 -- subprograms and flag them as erroneous.
2274
2275 else
2276 Decl := First (Vis_Decls);
2277
2278 while Present (Decl) loop
2279 if Nkind (Decl) = N_Entry_Declaration
2280 and then Must_Override (Decl)
2281 then
2282 Def_Id := Defining_Identifier (Decl);
2283 Error_Msg_NE ("entry& is not overriding", Def_Id, Def_Id);
2284
2285 elsif Nkind (Decl) = N_Subprogram_Declaration
2286 and then Must_Override (Specification (Decl))
2287 then
2288 Def_Id := Defining_Identifier (Specification (Decl));
2289 Error_Msg_NE ("subprogram& is not overriding", Def_Id, Def_Id);
2290 end if;
2291
2292 Next (Decl);
2293 end loop;
2294 end if;
2295 end Check_Overriding_Indicator;
2296
2297 --------------------------
2298 -- Find_Concurrent_Spec --
2299 --------------------------
2300
2301 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
2302 Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
2303
2304 begin
2305 -- The type may have been given by an incomplete type declaration.
2306 -- Find full view now.
2307
2308 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
2309 Spec_Id := Full_View (Spec_Id);
2310 end if;
2311
2312 return Spec_Id;
2313 end Find_Concurrent_Spec;
2314
2315 --------------------------
2316 -- Install_Declarations --
2317 --------------------------
2318
2319 procedure Install_Declarations (Spec : Entity_Id) is
2320 E : Entity_Id;
2321 Prev : Entity_Id;
2322
2323 begin
2324 E := First_Entity (Spec);
2325
2326 while Present (E) loop
2327 Prev := Current_Entity (E);
2328 Set_Current_Entity (E);
2329 Set_Is_Immediately_Visible (E);
2330 Set_Homonym (E, Prev);
2331 Next_Entity (E);
2332 end loop;
2333 end Install_Declarations;
2334
2335 end Sem_Ch9;
Mirror of the offical gcc git repository hosted at gcc.gnu.org