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