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