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