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