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