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