File : sem_ch9.adb
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-2016, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Contracts; use Contracts;
30 with Debug; use Debug;
31 with Einfo; use Einfo;
32 with Errout; use Errout;
33 with Exp_Ch9; use Exp_Ch9;
34 with Elists; use Elists;
35 with Fname; use Fname;
36 with Freeze; use Freeze;
37 with Layout; use Layout;
38 with Lib; use Lib;
39 with Lib.Xref; use Lib.Xref;
40 with Namet; use Namet;
41 with Nlists; use Nlists;
42 with Nmake; use Nmake;
43 with Opt; use Opt;
44 with Restrict; use Restrict;
45 with Rident; use Rident;
46 with Rtsfind; use Rtsfind;
47 with Sem; use Sem;
48 with Sem_Aux; use Sem_Aux;
49 with Sem_Ch3; use Sem_Ch3;
50 with Sem_Ch5; use Sem_Ch5;
51 with Sem_Ch6; use Sem_Ch6;
52 with Sem_Ch8; use Sem_Ch8;
53 with Sem_Ch13; use Sem_Ch13;
54 with Sem_Eval; use Sem_Eval;
55 with Sem_Prag; use Sem_Prag;
56 with Sem_Res; use Sem_Res;
57 with Sem_Type; use Sem_Type;
58 with Sem_Util; use Sem_Util;
59 with Sem_Warn; use Sem_Warn;
60 with Snames; use Snames;
61 with Stand; use Stand;
62 with Sinfo; use Sinfo;
63 with Style;
64 with Tbuild; use Tbuild;
65 with Uintp; use Uintp;
66
67 package body Sem_Ch9 is
68
69 -----------------------
70 -- Local Subprograms --
71 -----------------------
72
73 function Allows_Lock_Free_Implementation
74 (N : Node_Id;
75 Lock_Free_Given : Boolean := False) return Boolean;
76 -- This routine returns True iff N satisfies the following list of lock-
77 -- free restrictions for protected type declaration and protected body:
78 --
79 -- 1) Protected type declaration
80 -- May not contain entries
81 -- Protected subprogram declarations may not have non-elementary
82 -- parameters.
83 --
84 -- 2) Protected Body
85 -- Each protected subprogram body within N must satisfy:
86 -- May reference only one protected component
87 -- May not reference non-constant entities outside the protected
88 -- subprogram scope.
89 -- May not contain address representation items, allocators and
90 -- quantified expressions.
91 -- May not contain delay, goto, loop and procedure call
92 -- statements.
93 -- May not contain exported and imported entities
94 -- May not dereference access values
95 -- Function calls and attribute references must be static
96 --
97 -- If Lock_Free_Given is True, an error message is issued when False is
98 -- returned.
99
100 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
101 -- Given either a protected definition or a task definition in D, check
102 -- the corresponding restriction parameter identifier R, and if it is set,
103 -- count the entries (checking the static requirement), and compare with
104 -- the given maximum.
105
106 procedure Check_Interfaces (N : Node_Id; T : Entity_Id);
107 -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node.
108 -- Complete decoration of T and check legality of the covered interfaces.
109
110 procedure Check_Triggering_Statement
111 (Trigger : Node_Id;
112 Error_Node : Node_Id;
113 Is_Dispatching : out Boolean);
114 -- Examine the triggering statement of a select statement, conditional or
115 -- timed entry call. If Trigger is a dispatching call, return its status
116 -- in Is_Dispatching and check whether the primitive belongs to a limited
117 -- interface. If it does not, emit an error at Error_Node.
118
119 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
120 -- Find entity in corresponding task or protected declaration. Use full
121 -- view if first declaration was for an incomplete type.
122
123 -------------------------------------
124 -- Allows_Lock_Free_Implementation --
125 -------------------------------------
126
127 function Allows_Lock_Free_Implementation
128 (N : Node_Id;
129 Lock_Free_Given : Boolean := False) return Boolean
130 is
131 Errors_Count : Nat;
132 -- Errors_Count is a count of errors detected by the compiler so far
133 -- when Lock_Free_Given is True.
134
135 begin
136 pragma Assert (Nkind_In (N, N_Protected_Type_Declaration,
137 N_Protected_Body));
138
139 -- The lock-free implementation is currently enabled through a debug
140 -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the
141 -- lock-free implementation. In that case, the debug flag is not needed.
142
143 if not Lock_Free_Given and then not Debug_Flag_9 then
144 return False;
145 end if;
146
147 -- Get the number of errors detected by the compiler so far
148
149 if Lock_Free_Given then
150 Errors_Count := Serious_Errors_Detected;
151 end if;
152
153 -- Protected type declaration case
154
155 if Nkind (N) = N_Protected_Type_Declaration then
156 declare
157 Pdef : constant Node_Id := Protected_Definition (N);
158 Priv_Decls : constant List_Id := Private_Declarations (Pdef);
159 Vis_Decls : constant List_Id := Visible_Declarations (Pdef);
160 Decl : Node_Id;
161
162 begin
163 -- Examine the visible and the private declarations
164
165 Decl := First (Vis_Decls);
166 while Present (Decl) loop
167
168 -- Entries and entry families are not allowed by the lock-free
169 -- restrictions.
170
171 if Nkind (Decl) = N_Entry_Declaration then
172 if Lock_Free_Given then
173 Error_Msg_N
174 ("entry not allowed when Lock_Free given", Decl);
175 else
176 return False;
177 end if;
178
179 -- Non-elementary parameters in protected procedure are not
180 -- allowed by the lock-free restrictions.
181
182 elsif Nkind (Decl) = N_Subprogram_Declaration
183 and then
184 Nkind (Specification (Decl)) = N_Procedure_Specification
185 and then
186 Present (Parameter_Specifications (Specification (Decl)))
187 then
188 declare
189 Par_Specs : constant List_Id :=
190 Parameter_Specifications
191 (Specification (Decl));
192
193 Par : Node_Id;
194
195 begin
196 Par := First (Par_Specs);
197 while Present (Par) loop
198 if not Is_Elementary_Type
199 (Etype (Defining_Identifier (Par)))
200 then
201 if Lock_Free_Given then
202 Error_Msg_NE
203 ("non-elementary parameter& not allowed "
204 & "when Lock_Free given",
205 Par, Defining_Identifier (Par));
206 else
207 return False;
208 end if;
209 end if;
210
211 Next (Par);
212 end loop;
213 end;
214 end if;
215
216 -- Examine private declarations after visible declarations
217
218 if No (Next (Decl))
219 and then List_Containing (Decl) = Vis_Decls
220 then
221 Decl := First (Priv_Decls);
222 else
223 Next (Decl);
224 end if;
225 end loop;
226 end;
227
228 -- Protected body case
229
230 else
231 Protected_Body_Case : declare
232 Decls : constant List_Id := Declarations (N);
233 Pid : constant Entity_Id := Corresponding_Spec (N);
234 Prot_Typ_Decl : constant Node_Id := Parent (Pid);
235 Prot_Def : constant Node_Id :=
236 Protected_Definition (Prot_Typ_Decl);
237 Priv_Decls : constant List_Id :=
238 Private_Declarations (Prot_Def);
239 Decl : Node_Id;
240
241 function Satisfies_Lock_Free_Requirements
242 (Sub_Body : Node_Id) return Boolean;
243 -- Return True if protected subprogram body Sub_Body satisfies all
244 -- requirements of a lock-free implementation.
245
246 --------------------------------------
247 -- Satisfies_Lock_Free_Requirements --
248 --------------------------------------
249
250 function Satisfies_Lock_Free_Requirements
251 (Sub_Body : Node_Id) return Boolean
252 is
253 Is_Procedure : constant Boolean :=
254 Ekind (Corresponding_Spec (Sub_Body)) =
255 E_Procedure;
256 -- Indicates if Sub_Body is a procedure body
257
258 Comp : Entity_Id := Empty;
259 -- Track the current component which the body references
260
261 Errors_Count : Nat;
262 -- Errors_Count is a count of errors detected by the compiler
263 -- so far when Lock_Free_Given is True.
264
265 function Check_Node (N : Node_Id) return Traverse_Result;
266 -- Check that node N meets the lock free restrictions
267
268 ----------------
269 -- Check_Node --
270 ----------------
271
272 function Check_Node (N : Node_Id) return Traverse_Result is
273 Kind : constant Node_Kind := Nkind (N);
274
275 -- The following function belongs in sem_eval ???
276
277 function Is_Static_Function (Attr : Node_Id) return Boolean;
278 -- Given an attribute reference node Attr, return True if
279 -- Attr denotes a static function according to the rules in
280 -- (RM 4.9 (22)).
281
282 ------------------------
283 -- Is_Static_Function --
284 ------------------------
285
286 function Is_Static_Function
287 (Attr : Node_Id) return Boolean
288 is
289 Para : Node_Id;
290
291 begin
292 pragma Assert (Nkind (Attr) = N_Attribute_Reference);
293
294 case Attribute_Name (Attr) is
295 when Name_Min |
296 Name_Max |
297 Name_Pred |
298 Name_Succ |
299 Name_Value |
300 Name_Wide_Value |
301 Name_Wide_Wide_Value =>
302
303 -- A language-defined attribute denotes a static
304 -- function if the prefix denotes a static scalar
305 -- subtype, and if the parameter and result types
306 -- are scalar (RM 4.9 (22)).
307
308 if Is_Scalar_Type (Etype (Attr))
309 and then Is_Scalar_Type (Etype (Prefix (Attr)))
310 and then
311 Is_OK_Static_Subtype (Etype (Prefix (Attr)))
312 then
313 Para := First (Expressions (Attr));
314
315 while Present (Para) loop
316 if not Is_Scalar_Type (Etype (Para)) then
317 return False;
318 end if;
319
320 Next (Para);
321 end loop;
322
323 return True;
324
325 else
326 return False;
327 end if;
328
329 when others => return False;
330 end case;
331 end Is_Static_Function;
332
333 -- Start of processing for Check_Node
334
335 begin
336 if Is_Procedure then
337 -- Allocators restricted
338
339 if Kind = N_Allocator then
340 if Lock_Free_Given then
341 Error_Msg_N ("allocator not allowed", N);
342 return Skip;
343 end if;
344
345 return Abandon;
346
347 -- Aspects Address, Export and Import restricted
348
349 elsif Kind = N_Aspect_Specification then
350 declare
351 Asp_Name : constant Name_Id :=
352 Chars (Identifier (N));
353 Asp_Id : constant Aspect_Id :=
354 Get_Aspect_Id (Asp_Name);
355
356 begin
357 if Asp_Id = Aspect_Address or else
358 Asp_Id = Aspect_Export or else
359 Asp_Id = Aspect_Import
360 then
361 Error_Msg_Name_1 := Asp_Name;
362
363 if Lock_Free_Given then
364 Error_Msg_N ("aspect% not allowed", N);
365 return Skip;
366 end if;
367
368 return Abandon;
369 end if;
370 end;
371
372 -- Address attribute definition clause restricted
373
374 elsif Kind = N_Attribute_Definition_Clause
375 and then Get_Attribute_Id (Chars (N)) =
376 Attribute_Address
377 then
378 Error_Msg_Name_1 := Chars (N);
379
380 if Lock_Free_Given then
381 if From_Aspect_Specification (N) then
382 Error_Msg_N ("aspect% not allowed", N);
383 else
384 Error_Msg_N ("% clause not allowed", N);
385 end if;
386
387 return Skip;
388 end if;
389
390 return Abandon;
391
392 -- Non-static Attribute references that don't denote a
393 -- static function restricted.
394
395 elsif Kind = N_Attribute_Reference
396 and then not Is_OK_Static_Expression (N)
397 and then not Is_Static_Function (N)
398 then
399 if Lock_Free_Given then
400 Error_Msg_N
401 ("non-static attribute reference not allowed", N);
402 return Skip;
403 end if;
404
405 return Abandon;
406
407 -- Delay statements restricted
408
409 elsif Kind in N_Delay_Statement then
410 if Lock_Free_Given then
411 Error_Msg_N ("delay not allowed", N);
412 return Skip;
413 end if;
414
415 return Abandon;
416
417 -- Dereferences of access values restricted
418
419 elsif Kind = N_Explicit_Dereference
420 or else (Kind = N_Selected_Component
421 and then Is_Access_Type (Etype (Prefix (N))))
422 then
423 if Lock_Free_Given then
424 Error_Msg_N
425 ("dereference of access value not allowed", N);
426 return Skip;
427 end if;
428
429 return Abandon;
430
431 -- Non-static function calls restricted
432
433 elsif Kind = N_Function_Call
434 and then not Is_OK_Static_Expression (N)
435 then
436 if Lock_Free_Given then
437 Error_Msg_N
438 ("non-static function call not allowed", N);
439 return Skip;
440 end if;
441
442 return Abandon;
443
444 -- Goto statements restricted
445
446 elsif Kind = N_Goto_Statement then
447 if Lock_Free_Given then
448 Error_Msg_N ("goto statement not allowed", N);
449 return Skip;
450 end if;
451
452 return Abandon;
453
454 -- References
455
456 elsif Kind = N_Identifier
457 and then Present (Entity (N))
458 then
459 declare
460 Id : constant Entity_Id := Entity (N);
461 Sub_Id : constant Entity_Id :=
462 Corresponding_Spec (Sub_Body);
463
464 begin
465 -- Prohibit references to non-constant entities
466 -- outside the protected subprogram scope.
467
468 if Ekind (Id) in Assignable_Kind
469 and then not
470 Scope_Within_Or_Same (Scope (Id), Sub_Id)
471 and then not
472 Scope_Within_Or_Same
473 (Scope (Id),
474 Protected_Body_Subprogram (Sub_Id))
475 then
476 if Lock_Free_Given then
477 Error_Msg_NE
478 ("reference to global variable& not " &
479 "allowed", N, Id);
480 return Skip;
481 end if;
482
483 return Abandon;
484 end if;
485 end;
486
487 -- Loop statements restricted
488
489 elsif Kind = N_Loop_Statement then
490 if Lock_Free_Given then
491 Error_Msg_N ("loop not allowed", N);
492 return Skip;
493 end if;
494
495 return Abandon;
496
497 -- Pragmas Export and Import restricted
498
499 elsif Kind = N_Pragma then
500 declare
501 Prag_Name : constant Name_Id := Pragma_Name (N);
502 Prag_Id : constant Pragma_Id :=
503 Get_Pragma_Id (Prag_Name);
504
505 begin
506 if Prag_Id = Pragma_Export
507 or else Prag_Id = Pragma_Import
508 then
509 Error_Msg_Name_1 := Prag_Name;
510
511 if Lock_Free_Given then
512 if From_Aspect_Specification (N) then
513 Error_Msg_N ("aspect% not allowed", N);
514 else
515 Error_Msg_N ("pragma% not allowed", N);
516 end if;
517
518 return Skip;
519 end if;
520
521 return Abandon;
522 end if;
523 end;
524
525 -- Procedure call statements restricted
526
527 elsif Kind = N_Procedure_Call_Statement then
528 if Lock_Free_Given then
529 Error_Msg_N ("procedure call not allowed", N);
530 return Skip;
531 end if;
532
533 return Abandon;
534
535 -- Quantified expression restricted. Note that we have
536 -- to check the original node as well, since at this
537 -- stage, it may have been rewritten.
538
539 elsif Kind = N_Quantified_Expression
540 or else
541 Nkind (Original_Node (N)) = N_Quantified_Expression
542 then
543 if Lock_Free_Given then
544 Error_Msg_N
545 ("quantified expression not allowed", N);
546 return Skip;
547 end if;
548
549 return Abandon;
550 end if;
551 end if;
552
553 -- A protected subprogram (function or procedure) may
554 -- reference only one component of the protected type, plus
555 -- the type of the component must support atomic operation.
556
557 if Kind = N_Identifier
558 and then Present (Entity (N))
559 then
560 declare
561 Id : constant Entity_Id := Entity (N);
562 Comp_Decl : Node_Id;
563 Comp_Id : Entity_Id := Empty;
564 Comp_Type : Entity_Id;
565
566 begin
567 if Ekind (Id) = E_Component then
568 Comp_Id := Id;
569
570 elsif Ekind_In (Id, E_Constant, E_Variable)
571 and then Present (Prival_Link (Id))
572 then
573 Comp_Id := Prival_Link (Id);
574 end if;
575
576 if Present (Comp_Id) then
577 Comp_Decl := Parent (Comp_Id);
578 Comp_Type := Etype (Comp_Id);
579
580 if Nkind (Comp_Decl) = N_Component_Declaration
581 and then Is_List_Member (Comp_Decl)
582 and then List_Containing (Comp_Decl) = Priv_Decls
583 then
584 -- Skip generic types since, in that case, we
585 -- will not build a body anyway (in the generic
586 -- template), and the size in the template may
587 -- have a fake value.
588
589 if not Is_Generic_Type (Comp_Type) then
590
591 -- Make sure the protected component type has
592 -- size and alignment fields set at this
593 -- point whenever this is possible.
594
595 Layout_Type (Comp_Type);
596
597 if not
598 Support_Atomic_Primitives (Comp_Type)
599 then
600 if Lock_Free_Given then
601 Error_Msg_NE
602 ("type of& must support atomic " &
603 "operations",
604 N, Comp_Id);
605 return Skip;
606 end if;
607
608 return Abandon;
609 end if;
610 end if;
611
612 -- Check if another protected component has
613 -- already been accessed by the subprogram body.
614
615 if No (Comp) then
616 Comp := Comp_Id;
617
618 elsif Comp /= Comp_Id then
619 if Lock_Free_Given then
620 Error_Msg_N
621 ("only one protected component allowed",
622 N);
623 return Skip;
624 end if;
625
626 return Abandon;
627 end if;
628 end if;
629 end if;
630 end;
631 end if;
632
633 return OK;
634 end Check_Node;
635
636 function Check_All_Nodes is new Traverse_Func (Check_Node);
637
638 -- Start of processing for Satisfies_Lock_Free_Requirements
639
640 begin
641 -- Get the number of errors detected by the compiler so far
642
643 if Lock_Free_Given then
644 Errors_Count := Serious_Errors_Detected;
645 end if;
646
647 if Check_All_Nodes (Sub_Body) = OK
648 and then (not Lock_Free_Given
649 or else Errors_Count = Serious_Errors_Detected)
650 then
651 -- Establish a relation between the subprogram body and the
652 -- unique protected component it references.
653
654 if Present (Comp) then
655 Lock_Free_Subprogram_Table.Append
656 (Lock_Free_Subprogram'(Sub_Body, Comp));
657 end if;
658
659 return True;
660 else
661 return False;
662 end if;
663 end Satisfies_Lock_Free_Requirements;
664
665 -- Start of processing for Protected_Body_Case
666
667 begin
668 Decl := First (Decls);
669 while Present (Decl) loop
670 if Nkind (Decl) = N_Subprogram_Body
671 and then not Satisfies_Lock_Free_Requirements (Decl)
672 then
673 if Lock_Free_Given then
674 Error_Msg_N
675 ("illegal body when Lock_Free given", Decl);
676 else
677 return False;
678 end if;
679 end if;
680
681 Next (Decl);
682 end loop;
683 end Protected_Body_Case;
684 end if;
685
686 -- When Lock_Free is given, check if no error has been detected during
687 -- the process.
688
689 if Lock_Free_Given
690 and then Errors_Count /= Serious_Errors_Detected
691 then
692 return False;
693 end if;
694
695 return True;
696 end Allows_Lock_Free_Implementation;
697
698 -----------------------------
699 -- Analyze_Abort_Statement --
700 -----------------------------
701
702 procedure Analyze_Abort_Statement (N : Node_Id) is
703 T_Name : Node_Id;
704
705 begin
706 Tasking_Used := True;
707 Check_SPARK_05_Restriction ("abort statement is not allowed", N);
708
709 T_Name := First (Names (N));
710 while Present (T_Name) loop
711 Analyze (T_Name);
712
713 if Is_Task_Type (Etype (T_Name))
714 or else (Ada_Version >= Ada_2005
715 and then Ekind (Etype (T_Name)) = E_Class_Wide_Type
716 and then Is_Interface (Etype (T_Name))
717 and then Is_Task_Interface (Etype (T_Name)))
718 then
719 Resolve (T_Name);
720 else
721 if Ada_Version >= Ada_2005 then
722 Error_Msg_N ("expect task name or task interface class-wide "
723 & "object for ABORT", T_Name);
724 else
725 Error_Msg_N ("expect task name for ABORT", T_Name);
726 end if;
727
728 return;
729 end if;
730
731 Next (T_Name);
732 end loop;
733
734 Check_Restriction (No_Abort_Statements, N);
735 Check_Potentially_Blocking_Operation (N);
736 end Analyze_Abort_Statement;
737
738 --------------------------------
739 -- Analyze_Accept_Alternative --
740 --------------------------------
741
742 procedure Analyze_Accept_Alternative (N : Node_Id) is
743 begin
744 Tasking_Used := True;
745
746 if Present (Pragmas_Before (N)) then
747 Analyze_List (Pragmas_Before (N));
748 end if;
749
750 if Present (Condition (N)) then
751 Analyze_And_Resolve (Condition (N), Any_Boolean);
752 end if;
753
754 Analyze (Accept_Statement (N));
755
756 if Is_Non_Empty_List (Statements (N)) then
757 Analyze_Statements (Statements (N));
758 end if;
759 end Analyze_Accept_Alternative;
760
761 ------------------------------
762 -- Analyze_Accept_Statement --
763 ------------------------------
764
765 procedure Analyze_Accept_Statement (N : Node_Id) is
766 Nam : constant Entity_Id := Entry_Direct_Name (N);
767 Formals : constant List_Id := Parameter_Specifications (N);
768 Index : constant Node_Id := Entry_Index (N);
769 Stats : constant Node_Id := Handled_Statement_Sequence (N);
770 Accept_Id : Entity_Id;
771 Entry_Nam : Entity_Id;
772 E : Entity_Id;
773 Kind : Entity_Kind;
774 Task_Nam : Entity_Id;
775
776 begin
777 Tasking_Used := True;
778 Check_SPARK_05_Restriction ("accept statement is not allowed", N);
779
780 -- Entry name is initialized to Any_Id. It should get reset to the
781 -- matching entry entity. An error is signalled if it is not reset.
782
783 Entry_Nam := Any_Id;
784
785 for J in reverse 0 .. Scope_Stack.Last loop
786 Task_Nam := Scope_Stack.Table (J).Entity;
787 exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
788 Kind := Ekind (Task_Nam);
789
790 if Kind /= E_Block and then Kind /= E_Loop
791 and then not Is_Entry (Task_Nam)
792 then
793 Error_Msg_N ("enclosing body of accept must be a task", N);
794 return;
795 end if;
796 end loop;
797
798 if Ekind (Etype (Task_Nam)) /= E_Task_Type then
799 Error_Msg_N ("invalid context for accept statement", N);
800 return;
801 end if;
802
803 -- In order to process the parameters, we create a defining identifier
804 -- that can be used as the name of the scope. The name of the accept
805 -- statement itself is not a defining identifier, and we cannot use
806 -- its name directly because the task may have any number of accept
807 -- statements for the same entry.
808
809 if Present (Index) then
810 Accept_Id := New_Internal_Entity
811 (E_Entry_Family, Current_Scope, Sloc (N), 'E');
812 else
813 Accept_Id := New_Internal_Entity
814 (E_Entry, Current_Scope, Sloc (N), 'E');
815 end if;
816
817 Set_Etype (Accept_Id, Standard_Void_Type);
818 Set_Accept_Address (Accept_Id, New_Elmt_List);
819
820 if Present (Formals) then
821 Push_Scope (Accept_Id);
822 Process_Formals (Formals, N);
823 Create_Extra_Formals (Accept_Id);
824 End_Scope;
825 end if;
826
827 -- We set the default expressions processed flag because we don't need
828 -- default expression functions. This is really more like body entity
829 -- than a spec entity anyway.
830
831 Set_Default_Expressions_Processed (Accept_Id);
832
833 E := First_Entity (Etype (Task_Nam));
834 while Present (E) loop
835 if Chars (E) = Chars (Nam)
836 and then (Ekind (E) = Ekind (Accept_Id))
837 and then Type_Conformant (Accept_Id, E)
838 then
839 Entry_Nam := E;
840 exit;
841 end if;
842
843 Next_Entity (E);
844 end loop;
845
846 if Entry_Nam = Any_Id then
847 Error_Msg_N ("no entry declaration matches accept statement", N);
848 return;
849 else
850 Set_Entity (Nam, Entry_Nam);
851 Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False);
852 Style.Check_Identifier (Nam, Entry_Nam);
853 end if;
854
855 -- Verify that the entry is not hidden by a procedure declared in the
856 -- current block (pathological but possible).
857
858 if Current_Scope /= Task_Nam then
859 declare
860 E1 : Entity_Id;
861
862 begin
863 E1 := First_Entity (Current_Scope);
864 while Present (E1) loop
865 if Ekind (E1) = E_Procedure
866 and then Chars (E1) = Chars (Entry_Nam)
867 and then Type_Conformant (E1, Entry_Nam)
868 then
869 Error_Msg_N ("entry name is not visible", N);
870 end if;
871
872 Next_Entity (E1);
873 end loop;
874 end;
875 end if;
876
877 Set_Convention (Accept_Id, Convention (Entry_Nam));
878 Check_Fully_Conformant (Accept_Id, Entry_Nam, N);
879
880 for J in reverse 0 .. Scope_Stack.Last loop
881 exit when Task_Nam = Scope_Stack.Table (J).Entity;
882
883 if Entry_Nam = Scope_Stack.Table (J).Entity then
884 Error_Msg_N ("duplicate accept statement for same entry", N);
885 end if;
886 end loop;
887
888 declare
889 P : Node_Id := N;
890 begin
891 loop
892 P := Parent (P);
893 case Nkind (P) is
894 when N_Task_Body | N_Compilation_Unit =>
895 exit;
896 when N_Asynchronous_Select =>
897 Error_Msg_N ("accept statements are not allowed within" &
898 " an asynchronous select inner" &
899 " to the enclosing task body", N);
900 exit;
901 when others =>
902 null;
903 end case;
904 end loop;
905 end;
906
907 if Ekind (E) = E_Entry_Family then
908 if No (Index) then
909 Error_Msg_N ("missing entry index in accept for entry family", N);
910 else
911 Analyze_And_Resolve (Index, Entry_Index_Type (E));
912 Apply_Range_Check (Index, Entry_Index_Type (E));
913 end if;
914
915 elsif Present (Index) then
916 Error_Msg_N ("invalid entry index in accept for simple entry", N);
917 end if;
918
919 -- If label declarations present, analyze them. They are declared in the
920 -- enclosing task, but their enclosing scope is the entry itself, so
921 -- that goto's to the label are recognized as local to the accept.
922
923 if Present (Declarations (N)) then
924 declare
925 Decl : Node_Id;
926 Id : Entity_Id;
927
928 begin
929 Decl := First (Declarations (N));
930 while Present (Decl) loop
931 Analyze (Decl);
932
933 pragma Assert
934 (Nkind (Decl) = N_Implicit_Label_Declaration);
935
936 Id := Defining_Identifier (Decl);
937 Set_Enclosing_Scope (Id, Entry_Nam);
938 Next (Decl);
939 end loop;
940 end;
941 end if;
942
943 -- If statements are present, they must be analyzed in the context of
944 -- the entry, so that references to formals are correctly resolved. We
945 -- also have to add the declarations that are required by the expansion
946 -- of the accept statement in this case if expansion active.
947
948 -- In the case of a select alternative of a selective accept, the
949 -- expander references the address declaration even if there is no
950 -- statement list.
951
952 -- We also need to create the renaming declarations for the local
953 -- variables that will replace references to the formals within the
954 -- accept statement.
955
956 Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
957
958 -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
959 -- fields on all entry formals (this loop ignores all other entities).
960 -- Reset Referenced, Referenced_As_xxx and Has_Pragma_Unreferenced as
961 -- well, so that we can post accurate warnings on each accept statement
962 -- for the same entry.
963
964 E := First_Entity (Entry_Nam);
965 while Present (E) loop
966 if Is_Formal (E) then
967 Set_Never_Set_In_Source (E, True);
968 Set_Is_True_Constant (E, False);
969 Set_Current_Value (E, Empty);
970 Set_Referenced (E, False);
971 Set_Referenced_As_LHS (E, False);
972 Set_Referenced_As_Out_Parameter (E, False);
973 Set_Has_Pragma_Unreferenced (E, False);
974 end if;
975
976 Next_Entity (E);
977 end loop;
978
979 -- Analyze statements if present
980
981 if Present (Stats) then
982 Push_Scope (Entry_Nam);
983 Install_Declarations (Entry_Nam);
984
985 Set_Actual_Subtypes (N, Current_Scope);
986
987 Analyze (Stats);
988 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam);
989 End_Scope;
990 end if;
991
992 -- Some warning checks
993
994 Check_Potentially_Blocking_Operation (N);
995 Check_References (Entry_Nam, N);
996 Set_Entry_Accepted (Entry_Nam);
997 end Analyze_Accept_Statement;
998
999 ---------------------------------
1000 -- Analyze_Asynchronous_Select --
1001 ---------------------------------
1002
1003 procedure Analyze_Asynchronous_Select (N : Node_Id) is
1004 Is_Disp_Select : Boolean := False;
1005 Trigger : Node_Id;
1006
1007 begin
1008 Tasking_Used := True;
1009 Check_SPARK_05_Restriction ("select statement is not allowed", N);
1010 Check_Restriction (Max_Asynchronous_Select_Nesting, N);
1011 Check_Restriction (No_Select_Statements, N);
1012
1013 if Ada_Version >= Ada_2005 then
1014 Trigger := Triggering_Statement (Triggering_Alternative (N));
1015
1016 Analyze (Trigger);
1017
1018 -- Ada 2005 (AI-345): Check for a potential dispatching select
1019
1020 Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
1021 end if;
1022
1023 -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous
1024 -- select will have to duplicate the triggering statements. Postpone
1025 -- the analysis of the statements till expansion. Analyze only if the
1026 -- expander is disabled in order to catch any semantic errors.
1027
1028 if Is_Disp_Select then
1029 if not Expander_Active then
1030 Analyze_Statements (Statements (Abortable_Part (N)));
1031 Analyze (Triggering_Alternative (N));
1032 end if;
1033
1034 -- Analyze the statements. We analyze statements in the abortable part,
1035 -- because this is the section that is executed first, and that way our
1036 -- remembering of saved values and checks is accurate.
1037
1038 else
1039 Analyze_Statements (Statements (Abortable_Part (N)));
1040 Analyze (Triggering_Alternative (N));
1041 end if;
1042 end Analyze_Asynchronous_Select;
1043
1044 ------------------------------------
1045 -- Analyze_Conditional_Entry_Call --
1046 ------------------------------------
1047
1048 procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
1049 Trigger : constant Node_Id :=
1050 Entry_Call_Statement (Entry_Call_Alternative (N));
1051 Is_Disp_Select : Boolean := False;
1052
1053 begin
1054 Tasking_Used := True;
1055 Check_SPARK_05_Restriction ("select statement is not allowed", N);
1056 Check_Restriction (No_Select_Statements, N);
1057
1058 -- Ada 2005 (AI-345): The trigger may be a dispatching call
1059
1060 if Ada_Version >= Ada_2005 then
1061 Analyze (Trigger);
1062 Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
1063 end if;
1064
1065 if List_Length (Else_Statements (N)) = 1
1066 and then Nkind (First (Else_Statements (N))) in N_Delay_Statement
1067 then
1068 Error_Msg_N
1069 ("suspicious form of conditional entry call??!", N);
1070 Error_Msg_N
1071 ("\`SELECT OR` may be intended rather than `SELECT ELSE`??!", N);
1072 end if;
1073
1074 -- Postpone the analysis of the statements till expansion. Analyze only
1075 -- if the expander is disabled in order to catch any semantic errors.
1076
1077 if Is_Disp_Select then
1078 if not Expander_Active then
1079 Analyze (Entry_Call_Alternative (N));
1080 Analyze_Statements (Else_Statements (N));
1081 end if;
1082
1083 -- Regular select analysis
1084
1085 else
1086 Analyze (Entry_Call_Alternative (N));
1087 Analyze_Statements (Else_Statements (N));
1088 end if;
1089 end Analyze_Conditional_Entry_Call;
1090
1091 --------------------------------
1092 -- Analyze_Delay_Alternative --
1093 --------------------------------
1094
1095 procedure Analyze_Delay_Alternative (N : Node_Id) is
1096 Expr : Node_Id;
1097 Typ : Entity_Id;
1098
1099 begin
1100 Tasking_Used := True;
1101 Check_Restriction (No_Delay, N);
1102
1103 if Present (Pragmas_Before (N)) then
1104 Analyze_List (Pragmas_Before (N));
1105 end if;
1106
1107 if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then
1108 Expr := Expression (Delay_Statement (N));
1109
1110 -- Defer full analysis until the statement is expanded, to insure
1111 -- that generated code does not move past the guard. The delay
1112 -- expression is only evaluated if the guard is open.
1113
1114 if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
1115 Preanalyze_And_Resolve (Expr, Standard_Duration);
1116 else
1117 Preanalyze_And_Resolve (Expr);
1118 end if;
1119
1120 Typ := First_Subtype (Etype (Expr));
1121
1122 if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement
1123 and then not Is_RTE (Typ, RO_CA_Time)
1124 and then not Is_RTE (Typ, RO_RT_Time)
1125 then
1126 Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
1127 end if;
1128
1129 Check_Restriction (No_Fixed_Point, Expr);
1130
1131 else
1132 Analyze (Delay_Statement (N));
1133 end if;
1134
1135 if Present (Condition (N)) then
1136 Analyze_And_Resolve (Condition (N), Any_Boolean);
1137 end if;
1138
1139 if Is_Non_Empty_List (Statements (N)) then
1140 Analyze_Statements (Statements (N));
1141 end if;
1142 end Analyze_Delay_Alternative;
1143
1144 ----------------------------
1145 -- Analyze_Delay_Relative --
1146 ----------------------------
1147
1148 procedure Analyze_Delay_Relative (N : Node_Id) is
1149 E : constant Node_Id := Expression (N);
1150 begin
1151 Tasking_Used := True;
1152 Check_SPARK_05_Restriction ("delay statement is not allowed", N);
1153 Check_Restriction (No_Relative_Delay, N);
1154 Check_Restriction (No_Delay, N);
1155 Check_Potentially_Blocking_Operation (N);
1156 Analyze_And_Resolve (E, Standard_Duration);
1157 Check_Restriction (No_Fixed_Point, E);
1158 end Analyze_Delay_Relative;
1159
1160 -------------------------
1161 -- Analyze_Delay_Until --
1162 -------------------------
1163
1164 procedure Analyze_Delay_Until (N : Node_Id) is
1165 E : constant Node_Id := Expression (N);
1166 Typ : Entity_Id;
1167
1168 begin
1169 Tasking_Used := True;
1170 Check_SPARK_05_Restriction ("delay statement is not allowed", N);
1171 Check_Restriction (No_Delay, N);
1172 Check_Potentially_Blocking_Operation (N);
1173 Analyze (E);
1174 Typ := First_Subtype (Etype (E));
1175
1176 if not Is_RTE (Typ, RO_CA_Time) and then
1177 not Is_RTE (Typ, RO_RT_Time)
1178 then
1179 Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
1180 end if;
1181 end Analyze_Delay_Until;
1182
1183 ------------------------
1184 -- Analyze_Entry_Body --
1185 ------------------------
1186
1187 procedure Analyze_Entry_Body (N : Node_Id) is
1188 Id : constant Entity_Id := Defining_Identifier (N);
1189 Decls : constant List_Id := Declarations (N);
1190 Stats : constant Node_Id := Handled_Statement_Sequence (N);
1191 Formals : constant Node_Id := Entry_Body_Formal_Part (N);
1192 P_Type : constant Entity_Id := Current_Scope;
1193 E : Entity_Id;
1194 Entry_Name : Entity_Id;
1195
1196 begin
1197 -- An entry body "freezes" the contract of the nearest enclosing package
1198 -- body and all other contracts encountered in the same declarative part
1199 -- up to and excluding the entry body. This ensures that any annotations
1200 -- referenced by the contract of an entry or subprogram body declared
1201 -- within the current protected body are available.
1202
1203 Analyze_Previous_Contracts (N);
1204
1205 Tasking_Used := True;
1206
1207 -- Entry_Name is initialized to Any_Id. It should get reset to the
1208 -- matching entry entity. An error is signalled if it is not reset.
1209
1210 Entry_Name := Any_Id;
1211
1212 Analyze (Formals);
1213
1214 if Present (Entry_Index_Specification (Formals)) then
1215 Set_Ekind (Id, E_Entry_Family);
1216 else
1217 Set_Ekind (Id, E_Entry);
1218 end if;
1219
1220 Set_Etype (Id, Standard_Void_Type);
1221 Set_Scope (Id, Current_Scope);
1222 Set_Accept_Address (Id, New_Elmt_List);
1223
1224 -- Set the SPARK_Mode from the current context (may be overwritten later
1225 -- with an explicit pragma).
1226
1227 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma);
1228 Set_SPARK_Pragma_Inherited (Id);
1229
1230 -- Analyze any aspect specifications that appear on the entry body
1231
1232 if Has_Aspects (N) then
1233 Analyze_Aspect_Specifications_On_Body_Or_Stub (N);
1234 end if;
1235
1236 E := First_Entity (P_Type);
1237 while Present (E) loop
1238 if Chars (E) = Chars (Id)
1239 and then (Ekind (E) = Ekind (Id))
1240 and then Type_Conformant (Id, E)
1241 then
1242 Entry_Name := E;
1243 Set_Convention (Id, Convention (E));
1244 Set_Corresponding_Body (Parent (E), Id);
1245 Check_Fully_Conformant (Id, E, N);
1246
1247 if Ekind (Id) = E_Entry_Family then
1248 if not Fully_Conformant_Discrete_Subtypes (
1249 Discrete_Subtype_Definition (Parent (E)),
1250 Discrete_Subtype_Definition
1251 (Entry_Index_Specification (Formals)))
1252 then
1253 Error_Msg_N
1254 ("index not fully conformant with previous declaration",
1255 Discrete_Subtype_Definition
1256 (Entry_Index_Specification (Formals)));
1257
1258 else
1259 -- The elaboration of the entry body does not recompute the
1260 -- bounds of the index, which may have side effects. Inherit
1261 -- the bounds from the entry declaration. This is critical
1262 -- if the entry has a per-object constraint. If a bound is
1263 -- given by a discriminant, it must be reanalyzed in order
1264 -- to capture the discriminal of the current entry, rather
1265 -- than that of the protected type.
1266
1267 declare
1268 Index_Spec : constant Node_Id :=
1269 Entry_Index_Specification (Formals);
1270
1271 Def : constant Node_Id :=
1272 New_Copy_Tree
1273 (Discrete_Subtype_Definition (Parent (E)));
1274
1275 begin
1276 if Nkind
1277 (Original_Node
1278 (Discrete_Subtype_Definition (Index_Spec))) = N_Range
1279 then
1280 Set_Etype (Def, Empty);
1281 Set_Analyzed (Def, False);
1282
1283 -- Keep the original subtree to ensure a properly
1284 -- formed tree (e.g. for ASIS use).
1285
1286 Rewrite
1287 (Discrete_Subtype_Definition (Index_Spec), Def);
1288
1289 Set_Analyzed (Low_Bound (Def), False);
1290 Set_Analyzed (High_Bound (Def), False);
1291
1292 if Denotes_Discriminant (Low_Bound (Def)) then
1293 Set_Entity (Low_Bound (Def), Empty);
1294 end if;
1295
1296 if Denotes_Discriminant (High_Bound (Def)) then
1297 Set_Entity (High_Bound (Def), Empty);
1298 end if;
1299
1300 Analyze (Def);
1301 Make_Index (Def, Index_Spec);
1302 Set_Etype
1303 (Defining_Identifier (Index_Spec), Etype (Def));
1304 end if;
1305 end;
1306 end if;
1307 end if;
1308
1309 exit;
1310 end if;
1311
1312 Next_Entity (E);
1313 end loop;
1314
1315 if Entry_Name = Any_Id then
1316 Error_Msg_N ("no entry declaration matches entry body", N);
1317 return;
1318
1319 elsif Has_Completion (Entry_Name) then
1320 Error_Msg_N ("duplicate entry body", N);
1321 return;
1322
1323 else
1324 Set_Has_Completion (Entry_Name);
1325 Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False);
1326 Style.Check_Identifier (Id, Entry_Name);
1327 end if;
1328
1329 Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
1330 Push_Scope (Entry_Name);
1331
1332 Install_Declarations (Entry_Name);
1333 Set_Actual_Subtypes (N, Current_Scope);
1334
1335 -- The entity for the protected subprogram corresponding to the entry
1336 -- has been created. We retain the name of this entity in the entry
1337 -- body, for use when the corresponding subprogram body is created.
1338 -- Note that entry bodies have no Corresponding_Spec, and there is no
1339 -- easy link back in the tree between the entry body and the entity for
1340 -- the entry itself, which is why we must propagate some attributes
1341 -- explicitly from spec to body.
1342
1343 Set_Protected_Body_Subprogram
1344 (Id, Protected_Body_Subprogram (Entry_Name));
1345
1346 Set_Entry_Parameters_Type
1347 (Id, Entry_Parameters_Type (Entry_Name));
1348
1349 -- Add a declaration for the Protection object, renaming declarations
1350 -- for the discriminals and privals and finally a declaration for the
1351 -- entry family index (if applicable).
1352
1353 if Expander_Active
1354 and then Is_Protected_Type (P_Type)
1355 then
1356 Install_Private_Data_Declarations
1357 (Sloc (N), Entry_Name, P_Type, N, Decls);
1358 end if;
1359
1360 if Present (Decls) then
1361 Analyze_Declarations (Decls);
1362 Inspect_Deferred_Constant_Completion (Decls);
1363 end if;
1364
1365 -- Process the contract of the subprogram body after all declarations
1366 -- have been analyzed. This ensures that any contract-related pragmas
1367 -- are available through the N_Contract node of the body.
1368
1369 Analyze_Entry_Or_Subprogram_Body_Contract (Id);
1370
1371 if Present (Stats) then
1372 Analyze (Stats);
1373 end if;
1374
1375 -- Check for unreferenced variables etc. Before the Check_References
1376 -- call, we transfer Never_Set_In_Source and Referenced flags from
1377 -- parameters in the spec to the corresponding entities in the body,
1378 -- since we want the warnings on the body entities. Note that we do not
1379 -- have to transfer Referenced_As_LHS, since that flag can only be set
1380 -- for simple variables, but we include Has_Pragma_Unreferenced,
1381 -- which may have been specified for a formal in the body.
1382
1383 -- At the same time, we set the flags on the spec entities to suppress
1384 -- any warnings on the spec formals, since we also scan the spec.
1385 -- Finally, we propagate the Entry_Component attribute to the body
1386 -- formals, for use in the renaming declarations created later for the
1387 -- formals (see exp_ch9.Add_Formal_Renamings).
1388
1389 declare
1390 E1 : Entity_Id;
1391 E2 : Entity_Id;
1392
1393 begin
1394 E1 := First_Entity (Entry_Name);
1395 while Present (E1) loop
1396 E2 := First_Entity (Id);
1397 while Present (E2) loop
1398 exit when Chars (E1) = Chars (E2);
1399 Next_Entity (E2);
1400 end loop;
1401
1402 -- If no matching body entity, then we already had a detected
1403 -- error of some kind, so just don't worry about these warnings.
1404
1405 if No (E2) then
1406 goto Continue;
1407 end if;
1408
1409 if Ekind (E1) = E_Out_Parameter then
1410 Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
1411 Set_Never_Set_In_Source (E1, False);
1412 end if;
1413
1414 Set_Referenced (E2, Referenced (E1));
1415 Set_Referenced (E1);
1416 Set_Has_Pragma_Unreferenced (E2, Has_Pragma_Unreferenced (E1));
1417 Set_Entry_Component (E2, Entry_Component (E1));
1418
1419 <<Continue>>
1420 Next_Entity (E1);
1421 end loop;
1422
1423 Check_References (Id);
1424 end;
1425
1426 -- We still need to check references for the spec, since objects
1427 -- declared in the body are chained (in the First_Entity sense) to
1428 -- the spec rather than the body in the case of entries.
1429
1430 Check_References (Entry_Name);
1431
1432 -- Process the end label, and terminate the scope
1433
1434 Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name);
1435 End_Scope;
1436
1437 -- If this is an entry family, remove the loop created to provide
1438 -- a scope for the entry index.
1439
1440 if Ekind (Id) = E_Entry_Family
1441 and then Present (Entry_Index_Specification (Formals))
1442 then
1443 End_Scope;
1444 end if;
1445 end Analyze_Entry_Body;
1446
1447 ------------------------------------
1448 -- Analyze_Entry_Body_Formal_Part --
1449 ------------------------------------
1450
1451 procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
1452 Id : constant Entity_Id := Defining_Identifier (Parent (N));
1453 Index : constant Node_Id := Entry_Index_Specification (N);
1454 Formals : constant List_Id := Parameter_Specifications (N);
1455
1456 begin
1457 Tasking_Used := True;
1458
1459 if Present (Index) then
1460 Analyze (Index);
1461
1462 -- The entry index functions like a loop variable, thus it is known
1463 -- to have a valid value.
1464
1465 Set_Is_Known_Valid (Defining_Identifier (Index));
1466 end if;
1467
1468 if Present (Formals) then
1469 Set_Scope (Id, Current_Scope);
1470 Push_Scope (Id);
1471 Process_Formals (Formals, Parent (N));
1472 End_Scope;
1473 end if;
1474 end Analyze_Entry_Body_Formal_Part;
1475
1476 ------------------------------------
1477 -- Analyze_Entry_Call_Alternative --
1478 ------------------------------------
1479
1480 procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
1481 Call : constant Node_Id := Entry_Call_Statement (N);
1482
1483 begin
1484 Tasking_Used := True;
1485 Check_SPARK_05_Restriction ("entry call is not allowed", N);
1486
1487 if Present (Pragmas_Before (N)) then
1488 Analyze_List (Pragmas_Before (N));
1489 end if;
1490
1491 if Nkind (Call) = N_Attribute_Reference then
1492
1493 -- Possibly a stream attribute, but definitely illegal. Other
1494 -- illegalities, such as procedure calls, are diagnosed after
1495 -- resolution.
1496
1497 Error_Msg_N ("entry call alternative requires an entry call", Call);
1498 return;
1499 end if;
1500
1501 Analyze (Call);
1502
1503 -- An indirect call in this context is illegal. A procedure call that
1504 -- does not involve a renaming of an entry is illegal as well, but this
1505 -- and other semantic errors are caught during resolution.
1506
1507 if Nkind (Call) = N_Explicit_Dereference then
1508 Error_Msg_N
1509 ("entry call or dispatching primitive of interface required ", N);
1510 end if;
1511
1512 if Is_Non_Empty_List (Statements (N)) then
1513 Analyze_Statements (Statements (N));
1514 end if;
1515 end Analyze_Entry_Call_Alternative;
1516
1517 -------------------------------
1518 -- Analyze_Entry_Declaration --
1519 -------------------------------
1520
1521 procedure Analyze_Entry_Declaration (N : Node_Id) is
1522 D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
1523 Def_Id : constant Entity_Id := Defining_Identifier (N);
1524 Formals : constant List_Id := Parameter_Specifications (N);
1525
1526 begin
1527 Generate_Definition (Def_Id);
1528
1529 Tasking_Used := True;
1530
1531 -- Case of no discrete subtype definition
1532
1533 if No (D_Sdef) then
1534 Set_Ekind (Def_Id, E_Entry);
1535
1536 -- Processing for discrete subtype definition present
1537
1538 else
1539 Enter_Name (Def_Id);
1540 Set_Ekind (Def_Id, E_Entry_Family);
1541 Analyze (D_Sdef);
1542 Make_Index (D_Sdef, N, Def_Id);
1543
1544 -- Check subtype with predicate in entry family
1545
1546 Bad_Predicated_Subtype_Use
1547 ("subtype& has predicate, not allowed in entry family",
1548 D_Sdef, Etype (D_Sdef));
1549
1550 -- Check entry family static bounds outside allowed limits
1551
1552 -- Note: originally this check was not performed here, but in that
1553 -- case the check happens deep in the expander, and the message is
1554 -- posted at the wrong location, and omitted in -gnatc mode.
1555 -- If the type of the entry index is a generic formal, no check
1556 -- is possible. In an instance, the check is not static and a run-
1557 -- time exception will be raised if the bounds are unreasonable.
1558
1559 declare
1560 PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index);
1561 LB : constant Uint := Expr_Value (Type_Low_Bound (PEI));
1562 UB : constant Uint := Expr_Value (Type_High_Bound (PEI));
1563
1564 LBR : Node_Id;
1565 UBR : Node_Id;
1566
1567 begin
1568
1569 -- No bounds checking if the type is generic or if previous error.
1570 -- In an instance the check is dynamic.
1571
1572 if Is_Generic_Type (Etype (D_Sdef))
1573 or else In_Instance
1574 or else Error_Posted (D_Sdef)
1575 then
1576 goto Skip_LB;
1577
1578 elsif Nkind (D_Sdef) = N_Range then
1579 LBR := Low_Bound (D_Sdef);
1580
1581 elsif Is_Entity_Name (D_Sdef)
1582 and then Is_Type (Entity (D_Sdef))
1583 then
1584 LBR := Type_Low_Bound (Entity (D_Sdef));
1585
1586 else
1587 goto Skip_LB;
1588 end if;
1589
1590 if Is_OK_Static_Expression (LBR)
1591 and then Expr_Value (LBR) < LB
1592 then
1593 Error_Msg_Uint_1 := LB;
1594 Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef);
1595 end if;
1596
1597 <<Skip_LB>>
1598 if Is_Generic_Type (Etype (D_Sdef))
1599 or else In_Instance
1600 or else Error_Posted (D_Sdef)
1601 then
1602 goto Skip_UB;
1603
1604 elsif Nkind (D_Sdef) = N_Range then
1605 UBR := High_Bound (D_Sdef);
1606
1607 elsif Is_Entity_Name (D_Sdef)
1608 and then Is_Type (Entity (D_Sdef))
1609 then
1610 UBR := Type_High_Bound (Entity (D_Sdef));
1611
1612 else
1613 goto Skip_UB;
1614 end if;
1615
1616 if Is_OK_Static_Expression (UBR)
1617 and then Expr_Value (UBR) > UB
1618 then
1619 Error_Msg_Uint_1 := UB;
1620 Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef);
1621 end if;
1622
1623 <<Skip_UB>>
1624 null;
1625 end;
1626 end if;
1627
1628 -- Decorate Def_Id
1629
1630 Set_Etype (Def_Id, Standard_Void_Type);
1631 Set_Convention (Def_Id, Convention_Entry);
1632 Set_Accept_Address (Def_Id, New_Elmt_List);
1633
1634 -- Set the SPARK_Mode from the current context (may be overwritten later
1635 -- with an explicit pragma). Task entries are excluded because they are
1636 -- not completed by entry bodies.
1637
1638 if Ekind (Current_Scope) = E_Protected_Type then
1639 Set_SPARK_Pragma (Def_Id, SPARK_Mode_Pragma);
1640 Set_SPARK_Pragma_Inherited (Def_Id);
1641 end if;
1642
1643 -- Process formals
1644
1645 if Present (Formals) then
1646 Set_Scope (Def_Id, Current_Scope);
1647 Push_Scope (Def_Id);
1648 Process_Formals (Formals, N);
1649 Create_Extra_Formals (Def_Id);
1650 End_Scope;
1651 end if;
1652
1653 if Ekind (Def_Id) = E_Entry then
1654 New_Overloaded_Entity (Def_Id);
1655 end if;
1656
1657 Generate_Reference_To_Formals (Def_Id);
1658
1659 if Has_Aspects (N) then
1660 Analyze_Aspect_Specifications (N, Def_Id);
1661 end if;
1662 end Analyze_Entry_Declaration;
1663
1664 ---------------------------------------
1665 -- Analyze_Entry_Index_Specification --
1666 ---------------------------------------
1667
1668 -- The Defining_Identifier of the entry index specification is local to the
1669 -- entry body, but it must be available in the entry barrier which is
1670 -- evaluated outside of the entry body. The index is eventually renamed as
1671 -- a run-time object, so is visibility is strictly a front-end concern. In
1672 -- order to make it available to the barrier, we create an additional
1673 -- scope, as for a loop, whose only declaration is the index name. This
1674 -- loop is not attached to the tree and does not appear as an entity local
1675 -- to the protected type, so its existence need only be known to routines
1676 -- that process entry families.
1677
1678 procedure Analyze_Entry_Index_Specification (N : Node_Id) is
1679 Iden : constant Node_Id := Defining_Identifier (N);
1680 Def : constant Node_Id := Discrete_Subtype_Definition (N);
1681 Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L');
1682
1683 begin
1684 Tasking_Used := True;
1685 Analyze (Def);
1686
1687 -- There is no elaboration of the entry index specification. Therefore,
1688 -- if the index is a range, it is not resolved and expanded, but the
1689 -- bounds are inherited from the entry declaration, and reanalyzed.
1690 -- See Analyze_Entry_Body.
1691
1692 if Nkind (Def) /= N_Range then
1693 Make_Index (Def, N);
1694 end if;
1695
1696 Set_Ekind (Loop_Id, E_Loop);
1697 Set_Scope (Loop_Id, Current_Scope);
1698 Push_Scope (Loop_Id);
1699 Enter_Name (Iden);
1700 Set_Ekind (Iden, E_Entry_Index_Parameter);
1701 Set_Etype (Iden, Etype (Def));
1702 end Analyze_Entry_Index_Specification;
1703
1704 ----------------------------
1705 -- Analyze_Protected_Body --
1706 ----------------------------
1707
1708 procedure Analyze_Protected_Body (N : Node_Id) is
1709 Body_Id : constant Entity_Id := Defining_Identifier (N);
1710 Last_E : Entity_Id;
1711
1712 Spec_Id : Entity_Id;
1713 -- This is initially the entity of the protected object or protected
1714 -- type involved, but is replaced by the protected type always in the
1715 -- case of a single protected declaration, since this is the proper
1716 -- scope to be used.
1717
1718 Ref_Id : Entity_Id;
1719 -- This is the entity of the protected object or protected type
1720 -- involved, and is the entity used for cross-reference purposes (it
1721 -- differs from Spec_Id in the case of a single protected object, since
1722 -- Spec_Id is set to the protected type in this case).
1723
1724 function Lock_Free_Disabled return Boolean;
1725 -- This routine returns False if the protected object has a Lock_Free
1726 -- aspect specification or a Lock_Free pragma that turns off the
1727 -- lock-free implementation (e.g. whose expression is False).
1728
1729 ------------------------
1730 -- Lock_Free_Disabled --
1731 ------------------------
1732
1733 function Lock_Free_Disabled return Boolean is
1734 Ritem : constant Node_Id :=
1735 Get_Rep_Item
1736 (Spec_Id, Name_Lock_Free, Check_Parents => False);
1737
1738 begin
1739 if Present (Ritem) then
1740
1741 -- Pragma with one argument
1742
1743 if Nkind (Ritem) = N_Pragma
1744 and then Present (Pragma_Argument_Associations (Ritem))
1745 then
1746 return
1747 Is_False
1748 (Static_Boolean
1749 (Expression
1750 (First (Pragma_Argument_Associations (Ritem)))));
1751
1752 -- Aspect Specification with expression present
1753
1754 elsif Nkind (Ritem) = N_Aspect_Specification
1755 and then Present (Expression (Ritem))
1756 then
1757 return Is_False (Static_Boolean (Expression (Ritem)));
1758
1759 -- Otherwise, return False
1760
1761 else
1762 return False;
1763 end if;
1764 end if;
1765
1766 return False;
1767 end Lock_Free_Disabled;
1768
1769 -- Start of processing for Analyze_Protected_Body
1770
1771 begin
1772 -- A protected body "freezes" the contract of the nearest enclosing
1773 -- package body and all other contracts encountered in the same
1774 -- declarative part up to and excluding the protected body. This ensures
1775 -- that any annotations referenced by the contract of an entry or
1776 -- subprogram body declared within the current protected body are
1777 -- available.
1778
1779 Analyze_Previous_Contracts (N);
1780
1781 Tasking_Used := True;
1782 Set_Ekind (Body_Id, E_Protected_Body);
1783 Set_Etype (Body_Id, Standard_Void_Type);
1784 Spec_Id := Find_Concurrent_Spec (Body_Id);
1785
1786 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Protected_Type then
1787 null;
1788
1789 elsif Present (Spec_Id)
1790 and then Ekind (Etype (Spec_Id)) = E_Protected_Type
1791 and then not Comes_From_Source (Etype (Spec_Id))
1792 then
1793 null;
1794
1795 else
1796 Error_Msg_N ("missing specification for protected body", Body_Id);
1797 return;
1798 end if;
1799
1800 Ref_Id := Spec_Id;
1801 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1802 Style.Check_Identifier (Body_Id, Spec_Id);
1803
1804 -- The declarations are always attached to the type
1805
1806 if Ekind (Spec_Id) /= E_Protected_Type then
1807 Spec_Id := Etype (Spec_Id);
1808 end if;
1809
1810 if Has_Aspects (N) then
1811 Analyze_Aspect_Specifications (N, Body_Id);
1812 end if;
1813
1814 Push_Scope (Spec_Id);
1815 Set_Corresponding_Spec (N, Spec_Id);
1816 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1817 Set_Has_Completion (Spec_Id);
1818 Install_Declarations (Spec_Id);
1819 Expand_Protected_Body_Declarations (N, Spec_Id);
1820 Last_E := Last_Entity (Spec_Id);
1821
1822 Analyze_Declarations (Declarations (N));
1823
1824 -- For visibility purposes, all entities in the body are private. Set
1825 -- First_Private_Entity accordingly, if there was no private part in the
1826 -- protected declaration.
1827
1828 if No (First_Private_Entity (Spec_Id)) then
1829 if Present (Last_E) then
1830 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1831 else
1832 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1833 end if;
1834 end if;
1835
1836 Check_Completion (Body_Id);
1837 Check_References (Spec_Id);
1838 Process_End_Label (N, 't', Ref_Id);
1839 End_Scope;
1840
1841 -- When a Lock_Free aspect specification/pragma forces the lock-free
1842 -- implementation, verify the protected body meets all the restrictions,
1843 -- otherwise Allows_Lock_Free_Implementation issues an error message.
1844
1845 if Uses_Lock_Free (Spec_Id) then
1846 if not Allows_Lock_Free_Implementation (N, True) then
1847 return;
1848 end if;
1849
1850 -- In other cases, if there is no aspect specification/pragma that
1851 -- disables the lock-free implementation, check both the protected
1852 -- declaration and body satisfy the lock-free restrictions.
1853
1854 elsif not Lock_Free_Disabled
1855 and then Allows_Lock_Free_Implementation (Parent (Spec_Id))
1856 and then Allows_Lock_Free_Implementation (N)
1857 then
1858 Set_Uses_Lock_Free (Spec_Id);
1859 end if;
1860 end Analyze_Protected_Body;
1861
1862 ----------------------------------
1863 -- Analyze_Protected_Definition --
1864 ----------------------------------
1865
1866 procedure Analyze_Protected_Definition (N : Node_Id) is
1867 E : Entity_Id;
1868 L : Entity_Id;
1869
1870 procedure Undelay_Itypes (T : Entity_Id);
1871 -- Itypes created for the private components of a protected type
1872 -- do not receive freeze nodes, because there is no scope in which
1873 -- they can be elaborated, and they can depend on discriminants of
1874 -- the enclosed protected type. Given that the components can be
1875 -- composite types with inner components, we traverse recursively
1876 -- the private components of the protected type, and indicate that
1877 -- all itypes within are frozen. This ensures that no freeze nodes
1878 -- will be generated for them.
1879 --
1880 -- On the other hand, components of the corresponding record are
1881 -- frozen (or receive itype references) as for other records.
1882
1883 --------------------
1884 -- Undelay_Itypes --
1885 --------------------
1886
1887 procedure Undelay_Itypes (T : Entity_Id) is
1888 Comp : Entity_Id;
1889
1890 begin
1891 if Is_Protected_Type (T) then
1892 Comp := First_Private_Entity (T);
1893 elsif Is_Record_Type (T) then
1894 Comp := First_Entity (T);
1895 else
1896 return;
1897 end if;
1898
1899 while Present (Comp) loop
1900 if Is_Type (Comp)
1901 and then Is_Itype (Comp)
1902 then
1903 Set_Has_Delayed_Freeze (Comp, False);
1904 Set_Is_Frozen (Comp);
1905
1906 if Is_Record_Type (Comp)
1907 or else Is_Protected_Type (Comp)
1908 then
1909 Undelay_Itypes (Comp);
1910 end if;
1911 end if;
1912
1913 Next_Entity (Comp);
1914 end loop;
1915 end Undelay_Itypes;
1916
1917 -- Start of processing for Analyze_Protected_Definition
1918
1919 begin
1920 Tasking_Used := True;
1921 Check_SPARK_05_Restriction ("protected definition is not allowed", N);
1922 Analyze_Declarations (Visible_Declarations (N));
1923
1924 if Present (Private_Declarations (N))
1925 and then not Is_Empty_List (Private_Declarations (N))
1926 then
1927 L := Last_Entity (Current_Scope);
1928 Analyze_Declarations (Private_Declarations (N));
1929
1930 if Present (L) then
1931 Set_First_Private_Entity (Current_Scope, Next_Entity (L));
1932 else
1933 Set_First_Private_Entity (Current_Scope,
1934 First_Entity (Current_Scope));
1935 end if;
1936 end if;
1937
1938 E := First_Entity (Current_Scope);
1939 while Present (E) loop
1940 if Ekind_In (E, E_Function, E_Procedure) then
1941 Set_Convention (E, Convention_Protected);
1942 else
1943 Propagate_Concurrent_Flags (Current_Scope, Etype (E));
1944 end if;
1945
1946 Next_Entity (E);
1947 end loop;
1948
1949 Undelay_Itypes (Current_Scope);
1950
1951 Check_Max_Entries (N, Max_Protected_Entries);
1952 Process_End_Label (N, 'e', Current_Scope);
1953 end Analyze_Protected_Definition;
1954
1955 ----------------------------------------
1956 -- Analyze_Protected_Type_Declaration --
1957 ----------------------------------------
1958
1959 procedure Analyze_Protected_Type_Declaration (N : Node_Id) is
1960 Def_Id : constant Entity_Id := Defining_Identifier (N);
1961 E : Entity_Id;
1962 T : Entity_Id;
1963
1964 begin
1965 if No_Run_Time_Mode then
1966 Error_Msg_CRT ("protected type", N);
1967
1968 if Has_Aspects (N) then
1969 Analyze_Aspect_Specifications (N, Def_Id);
1970 end if;
1971
1972 return;
1973 end if;
1974
1975 Tasking_Used := True;
1976 Check_Restriction (No_Protected_Types, N);
1977
1978 T := Find_Type_Name (N);
1979
1980 -- In the case of an incomplete type, use the full view, unless it's not
1981 -- present (as can occur for an incomplete view from a limited with).
1982
1983 if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
1984 T := Full_View (T);
1985 Set_Completion_Referenced (T);
1986 end if;
1987
1988 Set_Ekind (T, E_Protected_Type);
1989 Set_Is_First_Subtype (T);
1990 Init_Size_Align (T);
1991 Set_Etype (T, T);
1992 Set_Has_Delayed_Freeze (T);
1993 Set_Stored_Constraint (T, No_Elist);
1994
1995 -- Mark this type as a protected type for the sake of restrictions,
1996 -- unless the protected type is declared in a private part of a package
1997 -- of the runtime. With this exception, the Suspension_Object from
1998 -- Ada.Synchronous_Task_Control can be implemented using a protected
1999 -- object without triggering violations of No_Local_Protected_Objects
2000 -- when the user locally declares such an object. This may look like a
2001 -- trick, but the user doesn't have to know how Suspension_Object is
2002 -- implemented.
2003
2004 if In_Private_Part (Current_Scope)
2005 and then Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
2006 then
2007 Set_Has_Protected (T, False);
2008 else
2009 Set_Has_Protected (T);
2010 end if;
2011
2012 -- Set the SPARK_Mode from the current context (may be overwritten later
2013 -- with an explicit pragma).
2014
2015 Set_SPARK_Pragma (T, SPARK_Mode_Pragma);
2016 Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma);
2017 Set_SPARK_Pragma_Inherited (T);
2018 Set_SPARK_Aux_Pragma_Inherited (T);
2019
2020 Push_Scope (T);
2021
2022 if Ada_Version >= Ada_2005 then
2023 Check_Interfaces (N, T);
2024 end if;
2025
2026 if Present (Discriminant_Specifications (N)) then
2027 if Has_Discriminants (T) then
2028
2029 -- Install discriminants. Also, verify conformance of
2030 -- discriminants of previous and current view. ???
2031
2032 Install_Declarations (T);
2033 else
2034 Process_Discriminants (N);
2035 end if;
2036 end if;
2037
2038 Set_Is_Constrained (T, not Has_Discriminants (T));
2039
2040 -- If aspects are present, analyze them now. They can make references to
2041 -- the discriminants of the type, but not to any components.
2042
2043 if Has_Aspects (N) then
2044
2045 -- The protected type is the full view of a private type. Analyze the
2046 -- aspects with the entity of the private type to ensure that after
2047 -- both views are exchanged, the aspect are actually associated with
2048 -- the full view.
2049
2050 if T /= Def_Id and then Is_Private_Type (Def_Id) then
2051 Analyze_Aspect_Specifications (N, T);
2052 else
2053 Analyze_Aspect_Specifications (N, Def_Id);
2054 end if;
2055 end if;
2056
2057 Analyze (Protected_Definition (N));
2058
2059 -- In the case where the protected type is declared at a nested level
2060 -- and the No_Local_Protected_Objects restriction applies, issue a
2061 -- warning that objects of the type will violate the restriction.
2062
2063 if Restriction_Check_Required (No_Local_Protected_Objects)
2064 and then not Is_Library_Level_Entity (T)
2065 and then Comes_From_Source (T)
2066 then
2067 Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects);
2068
2069 if Error_Msg_Sloc = No_Location then
2070 Error_Msg_N
2071 ("objects of this type will violate " &
2072 "`No_Local_Protected_Objects`??", N);
2073 else
2074 Error_Msg_N
2075 ("objects of this type will violate " &
2076 "`No_Local_Protected_Objects`#??", N);
2077 end if;
2078 end if;
2079
2080 -- Protected types with entries are controlled (because of the
2081 -- Protection component if nothing else), same for any protected type
2082 -- with interrupt handlers. Note that we need to analyze the protected
2083 -- definition to set Has_Entries and such.
2084
2085 if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
2086 or else Number_Entries (T) > 1)
2087 and then
2088 (Has_Entries (T)
2089 or else Has_Interrupt_Handler (T)
2090 or else Has_Attach_Handler (T))
2091 then
2092 Set_Has_Controlled_Component (T, True);
2093 end if;
2094
2095 -- The Ekind of components is E_Void during analysis to detect illegal
2096 -- uses. Now it can be set correctly.
2097
2098 E := First_Entity (Current_Scope);
2099 while Present (E) loop
2100 if Ekind (E) = E_Void then
2101 Set_Ekind (E, E_Component);
2102 Init_Component_Location (E);
2103 end if;
2104
2105 Next_Entity (E);
2106 end loop;
2107
2108 End_Scope;
2109
2110 -- When a Lock_Free aspect forces the lock-free implementation, check N
2111 -- meets all the lock-free restrictions. Otherwise, an error message is
2112 -- issued by Allows_Lock_Free_Implementation.
2113
2114 if Uses_Lock_Free (Defining_Identifier (N)) then
2115
2116 -- Complain when there is an explicit aspect/pragma Priority (or
2117 -- Interrupt_Priority) while the lock-free implementation is forced
2118 -- by an aspect/pragma.
2119
2120 declare
2121 Id : constant Entity_Id := Defining_Identifier (Original_Node (N));
2122 -- The warning must be issued on the original identifier in order
2123 -- to deal properly with the case of a single protected object.
2124
2125 Prio_Item : constant Node_Id :=
2126 Get_Rep_Item (Def_Id, Name_Priority, False);
2127
2128 begin
2129 if Present (Prio_Item) then
2130
2131 -- Aspect case
2132
2133 if Nkind (Prio_Item) = N_Aspect_Specification
2134 or else From_Aspect_Specification (Prio_Item)
2135 then
2136 Error_Msg_Name_1 := Chars (Identifier (Prio_Item));
2137 Error_Msg_NE
2138 ("aspect% for & has no effect when Lock_Free given??",
2139 Prio_Item, Id);
2140
2141 -- Pragma case
2142
2143 else
2144 Error_Msg_Name_1 := Pragma_Name (Prio_Item);
2145 Error_Msg_NE
2146 ("pragma% for & has no effect when Lock_Free given??",
2147 Prio_Item, Id);
2148 end if;
2149 end if;
2150 end;
2151
2152 if not Allows_Lock_Free_Implementation (N, Lock_Free_Given => True)
2153 then
2154 return;
2155 end if;
2156 end if;
2157
2158 -- If the Attach_Handler aspect is specified or the Interrupt_Handler
2159 -- aspect is True, then the initial ceiling priority must be in the
2160 -- range of System.Interrupt_Priority. It is therefore recommanded
2161 -- to use the Interrupt_Priority aspect instead of the Priority aspect.
2162
2163 if Has_Interrupt_Handler (T) or else Has_Attach_Handler (T) then
2164 declare
2165 Prio_Item : constant Node_Id :=
2166 Get_Rep_Item (Def_Id, Name_Priority, False);
2167
2168 begin
2169 if Present (Prio_Item) then
2170
2171 -- Aspect case
2172
2173 if (Nkind (Prio_Item) = N_Aspect_Specification
2174 or else From_Aspect_Specification (Prio_Item))
2175 and then Chars (Identifier (Prio_Item)) = Name_Priority
2176 then
2177 Error_Msg_N
2178 ("aspect Interrupt_Priority is preferred in presence of "
2179 & "handlers??", Prio_Item);
2180
2181 -- Pragma case
2182
2183 elsif Nkind (Prio_Item) = N_Pragma
2184 and then Pragma_Name (Prio_Item) = Name_Priority
2185 then
2186 Error_Msg_N
2187 ("pragma Interrupt_Priority is preferred in presence of "
2188 & "handlers??", Prio_Item);
2189 end if;
2190 end if;
2191 end;
2192 end if;
2193
2194 -- Case of a completion of a private declaration
2195
2196 if T /= Def_Id and then Is_Private_Type (Def_Id) then
2197
2198 -- Deal with preelaborable initialization. Note that this processing
2199 -- is done by Process_Full_View, but as can be seen below, in this
2200 -- case the call to Process_Full_View is skipped if any serious
2201 -- errors have occurred, and we don't want to lose this check.
2202
2203 if Known_To_Have_Preelab_Init (Def_Id) then
2204 Set_Must_Have_Preelab_Init (T);
2205 end if;
2206
2207 -- Propagate invariant-related attributes from the private type to
2208 -- the protected type.
2209
2210 Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
2211
2212 -- Create corresponding record now, because some private dependents
2213 -- may be subtypes of the partial view.
2214
2215 -- Skip if errors are present, to prevent cascaded messages
2216
2217 if Serious_Errors_Detected = 0
2218
2219 -- Also skip if expander is not active
2220
2221 and then Expander_Active
2222 then
2223 Expand_N_Protected_Type_Declaration (N);
2224 Process_Full_View (N, T, Def_Id);
2225 end if;
2226 end if;
2227 end Analyze_Protected_Type_Declaration;
2228
2229 ---------------------
2230 -- Analyze_Requeue --
2231 ---------------------
2232
2233 procedure Analyze_Requeue (N : Node_Id) is
2234 Count : Natural := 0;
2235 Entry_Name : Node_Id := Name (N);
2236 Entry_Id : Entity_Id;
2237 I : Interp_Index;
2238 Is_Disp_Req : Boolean;
2239 It : Interp;
2240 Enclosing : Entity_Id;
2241 Target_Obj : Node_Id := Empty;
2242 Req_Scope : Entity_Id;
2243 Outer_Ent : Entity_Id;
2244 Synch_Type : Entity_Id;
2245
2246 begin
2247 Tasking_Used := True;
2248 Check_SPARK_05_Restriction ("requeue statement is not allowed", N);
2249 Check_Restriction (No_Requeue_Statements, N);
2250 Check_Unreachable_Code (N);
2251
2252 Enclosing := Empty;
2253 for J in reverse 0 .. Scope_Stack.Last loop
2254 Enclosing := Scope_Stack.Table (J).Entity;
2255 exit when Is_Entry (Enclosing);
2256
2257 if not Ekind_In (Enclosing, E_Block, E_Loop) then
2258 Error_Msg_N ("requeue must appear within accept or entry body", N);
2259 return;
2260 end if;
2261 end loop;
2262
2263 Analyze (Entry_Name);
2264
2265 if Etype (Entry_Name) = Any_Type then
2266 return;
2267 end if;
2268
2269 if Nkind (Entry_Name) = N_Selected_Component then
2270 Target_Obj := Prefix (Entry_Name);
2271 Entry_Name := Selector_Name (Entry_Name);
2272 end if;
2273
2274 -- If an explicit target object is given then we have to check the
2275 -- restrictions of 9.5.4(6).
2276
2277 if Present (Target_Obj) then
2278
2279 -- Locate containing concurrent unit and determine enclosing entry
2280 -- body or outermost enclosing accept statement within the unit.
2281
2282 Outer_Ent := Empty;
2283 for S in reverse 0 .. Scope_Stack.Last loop
2284 Req_Scope := Scope_Stack.Table (S).Entity;
2285
2286 exit when Ekind (Req_Scope) in Task_Kind
2287 or else Ekind (Req_Scope) in Protected_Kind;
2288
2289 if Is_Entry (Req_Scope) then
2290 Outer_Ent := Req_Scope;
2291 end if;
2292 end loop;
2293
2294 pragma Assert (Present (Outer_Ent));
2295
2296 -- Check that the accessibility level of the target object is not
2297 -- greater or equal to the outermost enclosing accept statement (or
2298 -- entry body) unless it is a parameter of the innermost enclosing
2299 -- accept statement (or entry body).
2300
2301 if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
2302 and then
2303 (not Is_Entity_Name (Target_Obj)
2304 or else Ekind (Entity (Target_Obj)) not in Formal_Kind
2305 or else Enclosing /= Scope (Entity (Target_Obj)))
2306 then
2307 Error_Msg_N
2308 ("target object has invalid level for requeue", Target_Obj);
2309 end if;
2310 end if;
2311
2312 -- Overloaded case, find right interpretation
2313
2314 if Is_Overloaded (Entry_Name) then
2315 Entry_Id := Empty;
2316
2317 -- Loop over candidate interpretations and filter out any that are
2318 -- not parameterless, are not type conformant, are not entries, or
2319 -- do not come from source.
2320
2321 Get_First_Interp (Entry_Name, I, It);
2322 while Present (It.Nam) loop
2323
2324 -- Note: we test type conformance here, not subtype conformance.
2325 -- Subtype conformance will be tested later on, but it is better
2326 -- for error output in some cases not to do that here.
2327
2328 if (No (First_Formal (It.Nam))
2329 or else (Type_Conformant (Enclosing, It.Nam)))
2330 and then Ekind (It.Nam) = E_Entry
2331 then
2332 -- Ada 2005 (AI-345): Since protected and task types have
2333 -- primitive entry wrappers, we only consider source entries.
2334
2335 if Comes_From_Source (It.Nam) then
2336 Count := Count + 1;
2337 Entry_Id := It.Nam;
2338 else
2339 Remove_Interp (I);
2340 end if;
2341 end if;
2342
2343 Get_Next_Interp (I, It);
2344 end loop;
2345
2346 if Count = 0 then
2347 Error_Msg_N ("no entry matches context", N);
2348 return;
2349
2350 elsif Count > 1 then
2351 Error_Msg_N ("ambiguous entry name in requeue", N);
2352 return;
2353
2354 else
2355 Set_Is_Overloaded (Entry_Name, False);
2356 Set_Entity (Entry_Name, Entry_Id);
2357 end if;
2358
2359 -- Non-overloaded cases
2360
2361 -- For the case of a reference to an element of an entry family, the
2362 -- Entry_Name is an indexed component.
2363
2364 elsif Nkind (Entry_Name) = N_Indexed_Component then
2365
2366 -- Requeue to an entry out of the body
2367
2368 if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
2369 Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
2370
2371 -- Requeue from within the body itself
2372
2373 elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
2374 Entry_Id := Entity (Prefix (Entry_Name));
2375
2376 else
2377 Error_Msg_N ("invalid entry_name specified", N);
2378 return;
2379 end if;
2380
2381 -- If we had a requeue of the form REQUEUE A (B), then the parser
2382 -- accepted it (because it could have been a requeue on an entry index.
2383 -- If A turns out not to be an entry family, then the analysis of A (B)
2384 -- turned it into a function call.
2385
2386 elsif Nkind (Entry_Name) = N_Function_Call then
2387 Error_Msg_N
2388 ("arguments not allowed in requeue statement",
2389 First (Parameter_Associations (Entry_Name)));
2390 return;
2391
2392 -- Normal case of no entry family, no argument
2393
2394 else
2395 Entry_Id := Entity (Entry_Name);
2396 end if;
2397
2398 -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The
2399 -- target type must be a concurrent interface class-wide type and the
2400 -- target must be a procedure, flagged by pragma Implemented. The
2401 -- target may be an access to class-wide type, in which case it must
2402 -- be dereferenced.
2403
2404 if Present (Target_Obj) then
2405 Synch_Type := Etype (Target_Obj);
2406
2407 if Is_Access_Type (Synch_Type) then
2408 Synch_Type := Designated_Type (Synch_Type);
2409 end if;
2410 end if;
2411
2412 Is_Disp_Req :=
2413 Ada_Version >= Ada_2012
2414 and then Present (Target_Obj)
2415 and then Is_Class_Wide_Type (Synch_Type)
2416 and then Is_Concurrent_Interface (Synch_Type)
2417 and then Ekind (Entry_Id) = E_Procedure
2418 and then Has_Rep_Pragma (Entry_Id, Name_Implemented);
2419
2420 -- Resolve entry, and check that it is subtype conformant with the
2421 -- enclosing construct if this construct has formals (RM 9.5.4(5)).
2422 -- Ada 2005 (AI05-0030): Do not emit an error for this specific case.
2423
2424 if not Is_Entry (Entry_Id)
2425 and then not Is_Disp_Req
2426 then
2427 Error_Msg_N ("expect entry name in requeue statement", Name (N));
2428
2429 elsif Ekind (Entry_Id) = E_Entry_Family
2430 and then Nkind (Entry_Name) /= N_Indexed_Component
2431 then
2432 Error_Msg_N ("missing index for entry family component", Name (N));
2433
2434 else
2435 Resolve_Entry (Name (N));
2436 Generate_Reference (Entry_Id, Entry_Name);
2437
2438 if Present (First_Formal (Entry_Id)) then
2439
2440 -- Ada 2012 (AI05-0030): Perform type conformance after skipping
2441 -- the first parameter of Entry_Id since it is the interface
2442 -- controlling formal.
2443
2444 if Ada_Version >= Ada_2012 and then Is_Disp_Req then
2445 declare
2446 Enclosing_Formal : Entity_Id;
2447 Target_Formal : Entity_Id;
2448
2449 begin
2450 Enclosing_Formal := First_Formal (Enclosing);
2451 Target_Formal := Next_Formal (First_Formal (Entry_Id));
2452 while Present (Enclosing_Formal)
2453 and then Present (Target_Formal)
2454 loop
2455 if not Conforming_Types
2456 (T1 => Etype (Enclosing_Formal),
2457 T2 => Etype (Target_Formal),
2458 Ctype => Subtype_Conformant)
2459 then
2460 Error_Msg_Node_2 := Target_Formal;
2461 Error_Msg_NE
2462 ("formal & is not subtype conformant with &" &
2463 "in dispatching requeue", N, Enclosing_Formal);
2464 end if;
2465
2466 Next_Formal (Enclosing_Formal);
2467 Next_Formal (Target_Formal);
2468 end loop;
2469 end;
2470 else
2471 Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
2472 end if;
2473
2474 -- Processing for parameters accessed by the requeue
2475
2476 declare
2477 Ent : Entity_Id;
2478
2479 begin
2480 Ent := First_Formal (Enclosing);
2481 while Present (Ent) loop
2482
2483 -- For OUT or IN OUT parameter, the effect of the requeue is
2484 -- to assign the parameter a value on exit from the requeued
2485 -- body, so we can set it as source assigned. We also clear
2486 -- the Is_True_Constant indication. We do not need to clear
2487 -- Current_Value, since the effect of the requeue is to
2488 -- perform an unconditional goto so that any further
2489 -- references will not occur anyway.
2490
2491 if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then
2492 Set_Never_Set_In_Source (Ent, False);
2493 Set_Is_True_Constant (Ent, False);
2494 end if;
2495
2496 -- For all parameters, the requeue acts as a reference,
2497 -- since the value of the parameter is passed to the new
2498 -- entry, so we want to suppress unreferenced warnings.
2499
2500 Set_Referenced (Ent);
2501 Next_Formal (Ent);
2502 end loop;
2503 end;
2504 end if;
2505 end if;
2506
2507 -- AI05-0225: the target protected object of a requeue must be a
2508 -- variable. This is a binding interpretation that applies to all
2509 -- versions of the language. Note that the subprogram does not have
2510 -- to be a protected operation: it can be an primitive implemented
2511 -- by entry with a formal that is a protected interface.
2512
2513 if Present (Target_Obj)
2514 and then not Is_Variable (Target_Obj)
2515 then
2516 Error_Msg_N
2517 ("target protected object of requeue must be a variable", N);
2518 end if;
2519 end Analyze_Requeue;
2520
2521 ------------------------------
2522 -- Analyze_Selective_Accept --
2523 ------------------------------
2524
2525 procedure Analyze_Selective_Accept (N : Node_Id) is
2526 Alts : constant List_Id := Select_Alternatives (N);
2527 Alt : Node_Id;
2528
2529 Accept_Present : Boolean := False;
2530 Terminate_Present : Boolean := False;
2531 Delay_Present : Boolean := False;
2532 Relative_Present : Boolean := False;
2533 Alt_Count : Uint := Uint_0;
2534
2535 begin
2536 Tasking_Used := True;
2537 Check_SPARK_05_Restriction ("select statement is not allowed", N);
2538 Check_Restriction (No_Select_Statements, N);
2539
2540 -- Loop to analyze alternatives
2541
2542 Alt := First (Alts);
2543 while Present (Alt) loop
2544 Alt_Count := Alt_Count + 1;
2545 Analyze (Alt);
2546
2547 if Nkind (Alt) = N_Delay_Alternative then
2548 if Delay_Present then
2549
2550 if Relative_Present /=
2551 (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
2552 then
2553 Error_Msg_N
2554 ("delay_until and delay_relative alternatives ", Alt);
2555 Error_Msg_N
2556 ("\cannot appear in the same selective_wait", Alt);
2557 end if;
2558
2559 else
2560 Delay_Present := True;
2561 Relative_Present :=
2562 Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
2563 end if;
2564
2565 elsif Nkind (Alt) = N_Terminate_Alternative then
2566 if Terminate_Present then
2567 Error_Msg_N ("only one terminate alternative allowed", N);
2568 else
2569 Terminate_Present := True;
2570 Check_Restriction (No_Terminate_Alternatives, N);
2571 end if;
2572
2573 elsif Nkind (Alt) = N_Accept_Alternative then
2574 Accept_Present := True;
2575
2576 -- Check for duplicate accept
2577
2578 declare
2579 Alt1 : Node_Id;
2580 Stm : constant Node_Id := Accept_Statement (Alt);
2581 EDN : constant Node_Id := Entry_Direct_Name (Stm);
2582 Ent : Entity_Id;
2583
2584 begin
2585 if Nkind (EDN) = N_Identifier
2586 and then No (Condition (Alt))
2587 and then Present (Entity (EDN)) -- defend against junk
2588 and then Ekind (Entity (EDN)) = E_Entry
2589 then
2590 Ent := Entity (EDN);
2591
2592 Alt1 := First (Alts);
2593 while Alt1 /= Alt loop
2594 if Nkind (Alt1) = N_Accept_Alternative
2595 and then No (Condition (Alt1))
2596 then
2597 declare
2598 Stm1 : constant Node_Id := Accept_Statement (Alt1);
2599 EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
2600
2601 begin
2602 if Nkind (EDN1) = N_Identifier then
2603 if Entity (EDN1) = Ent then
2604 Error_Msg_Sloc := Sloc (Stm1);
2605 Error_Msg_N
2606 ("accept duplicates one on line#??", Stm);
2607 exit;
2608 end if;
2609 end if;
2610 end;
2611 end if;
2612
2613 Next (Alt1);
2614 end loop;
2615 end if;
2616 end;
2617 end if;
2618
2619 Next (Alt);
2620 end loop;
2621
2622 Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
2623 Check_Potentially_Blocking_Operation (N);
2624
2625 if Terminate_Present and Delay_Present then
2626 Error_Msg_N ("at most one of terminate or delay alternative", N);
2627
2628 elsif not Accept_Present then
2629 Error_Msg_N
2630 ("select must contain at least one accept alternative", N);
2631 end if;
2632
2633 if Present (Else_Statements (N)) then
2634 if Terminate_Present or Delay_Present then
2635 Error_Msg_N ("else part not allowed with other alternatives", N);
2636 end if;
2637
2638 Analyze_Statements (Else_Statements (N));
2639 end if;
2640 end Analyze_Selective_Accept;
2641
2642 ------------------------------------------
2643 -- Analyze_Single_Protected_Declaration --
2644 ------------------------------------------
2645
2646 procedure Analyze_Single_Protected_Declaration (N : Node_Id) is
2647 Loc : constant Source_Ptr := Sloc (N);
2648 Obj_Id : constant Node_Id := Defining_Identifier (N);
2649 Obj_Decl : Node_Id;
2650 Typ : Entity_Id;
2651
2652 begin
2653 Generate_Definition (Obj_Id);
2654 Tasking_Used := True;
2655
2656 -- A single protected declaration is transformed into a pair of an
2657 -- anonymous protected type and an object of that type. Generate:
2658
2659 -- protected type Typ is ...;
2660
2661 Typ :=
2662 Make_Defining_Identifier (Sloc (Obj_Id),
2663 Chars => New_External_Name (Chars (Obj_Id), 'T'));
2664
2665 Rewrite (N,
2666 Make_Protected_Type_Declaration (Loc,
2667 Defining_Identifier => Typ,
2668 Protected_Definition => Relocate_Node (Protected_Definition (N)),
2669 Interface_List => Interface_List (N)));
2670
2671 -- Use the original defining identifier of the single protected
2672 -- declaration in the generated object declaration to allow for debug
2673 -- information to be attached to it when compiling with -gnatD. The
2674 -- parent of the entity is the new object declaration. The single
2675 -- protected declaration is not used in semantics or code generation,
2676 -- but is scanned when generating debug information, and therefore needs
2677 -- the updated Sloc information from the entity (see Sprint). Generate:
2678
2679 -- Obj : Typ;
2680
2681 Obj_Decl :=
2682 Make_Object_Declaration (Loc,
2683 Defining_Identifier => Obj_Id,
2684 Object_Definition => New_Occurrence_Of (Typ, Loc));
2685
2686 Insert_After (N, Obj_Decl);
2687 Mark_Rewrite_Insertion (Obj_Decl);
2688
2689 -- Relocate aspect Part_Of from the the original single protected
2690 -- declaration to the anonymous object declaration. This emulates the
2691 -- placement of an equivalent source pragma.
2692
2693 Move_Or_Merge_Aspects (N, To => Obj_Decl);
2694
2695 -- Relocate pragma Part_Of from the visible declarations of the original
2696 -- single protected declaration to the anonymous object declaration. The
2697 -- new placement better reflects the role of the pragma.
2698
2699 Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl);
2700
2701 -- Enter the names of the anonymous protected type and the object before
2702 -- analysis takes places, because the name of the object may be used in
2703 -- its own body.
2704
2705 Enter_Name (Typ);
2706 Set_Ekind (Typ, E_Protected_Type);
2707 Set_Etype (Typ, Typ);
2708 Set_Anonymous_Object (Typ, Obj_Id);
2709
2710 Enter_Name (Obj_Id);
2711 Set_Ekind (Obj_Id, E_Variable);
2712 Set_Etype (Obj_Id, Typ);
2713 Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
2714 Set_SPARK_Pragma_Inherited (Obj_Id);
2715
2716 -- Instead of calling Analyze on the new node, call the proper analysis
2717 -- procedure directly. Otherwise the node would be expanded twice, with
2718 -- disastrous result.
2719
2720 Analyze_Protected_Type_Declaration (N);
2721
2722 if Has_Aspects (N) then
2723 Analyze_Aspect_Specifications (N, Obj_Id);
2724 end if;
2725 end Analyze_Single_Protected_Declaration;
2726
2727 -------------------------------------
2728 -- Analyze_Single_Task_Declaration --
2729 -------------------------------------
2730
2731 procedure Analyze_Single_Task_Declaration (N : Node_Id) is
2732 Loc : constant Source_Ptr := Sloc (N);
2733 Obj_Id : constant Node_Id := Defining_Identifier (N);
2734 Obj_Decl : Node_Id;
2735 Typ : Entity_Id;
2736
2737 begin
2738 Generate_Definition (Obj_Id);
2739 Tasking_Used := True;
2740
2741 -- A single task declaration is transformed into a pait of an anonymous
2742 -- task type and an object of that type. Generate:
2743
2744 -- task type Typ is ...;
2745
2746 Typ :=
2747 Make_Defining_Identifier (Sloc (Obj_Id),
2748 Chars => New_External_Name (Chars (Obj_Id), Suffix => "TK"));
2749
2750 Rewrite (N,
2751 Make_Task_Type_Declaration (Loc,
2752 Defining_Identifier => Typ,
2753 Task_Definition => Relocate_Node (Task_Definition (N)),
2754 Interface_List => Interface_List (N)));
2755
2756 -- Use the original defining identifier of the single task declaration
2757 -- in the generated object declaration to allow for debug information
2758 -- to be attached to it when compiling with -gnatD. The parent of the
2759 -- entity is the new object declaration. The single task declaration
2760 -- is not used in semantics or code generation, but is scanned when
2761 -- generating debug information, and therefore needs the updated Sloc
2762 -- information from the entity (see Sprint). Generate:
2763
2764 -- Obj : Typ;
2765
2766 Obj_Decl :=
2767 Make_Object_Declaration (Loc,
2768 Defining_Identifier => Obj_Id,
2769 Object_Definition => New_Occurrence_Of (Typ, Loc));
2770
2771 Insert_After (N, Obj_Decl);
2772 Mark_Rewrite_Insertion (Obj_Decl);
2773
2774 -- Relocate aspects Depends, Global and Part_Of from the original single
2775 -- task declaration to the anonymous object declaration. This emulates
2776 -- the placement of an equivalent source pragma.
2777
2778 Move_Or_Merge_Aspects (N, To => Obj_Decl);
2779
2780 -- Relocate pragmas Depends, Global and Part_Of from the visible
2781 -- declarations of the original single protected declaration to the
2782 -- anonymous object declaration. The new placement better reflects the
2783 -- role of the pragmas.
2784
2785 Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl);
2786
2787 -- Enter the names of the anonymous task type and the object before
2788 -- analysis takes places, because the name of the object may be used
2789 -- in its own body.
2790
2791 Enter_Name (Typ);
2792 Set_Ekind (Typ, E_Task_Type);
2793 Set_Etype (Typ, Typ);
2794 Set_Anonymous_Object (Typ, Obj_Id);
2795
2796 Enter_Name (Obj_Id);
2797 Set_Ekind (Obj_Id, E_Variable);
2798 Set_Etype (Obj_Id, Typ);
2799 Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
2800 Set_SPARK_Pragma_Inherited (Obj_Id);
2801
2802 -- Instead of calling Analyze on the new node, call the proper analysis
2803 -- procedure directly. Otherwise the node would be expanded twice, with
2804 -- disastrous result.
2805
2806 Analyze_Task_Type_Declaration (N);
2807
2808 if Has_Aspects (N) then
2809 Analyze_Aspect_Specifications (N, Obj_Id);
2810 end if;
2811 end Analyze_Single_Task_Declaration;
2812
2813 -----------------------
2814 -- Analyze_Task_Body --
2815 -----------------------
2816
2817 procedure Analyze_Task_Body (N : Node_Id) is
2818 Body_Id : constant Entity_Id := Defining_Identifier (N);
2819 Decls : constant List_Id := Declarations (N);
2820 HSS : constant Node_Id := Handled_Statement_Sequence (N);
2821 Last_E : Entity_Id;
2822
2823 Spec_Id : Entity_Id;
2824 -- This is initially the entity of the task or task type involved, but
2825 -- is replaced by the task type always in the case of a single task
2826 -- declaration, since this is the proper scope to be used.
2827
2828 Ref_Id : Entity_Id;
2829 -- This is the entity of the task or task type, and is the entity used
2830 -- for cross-reference purposes (it differs from Spec_Id in the case of
2831 -- a single task, since Spec_Id is set to the task type).
2832
2833 begin
2834 -- A task body "freezes" the contract of the nearest enclosing package
2835 -- body and all other contracts encountered in the same declarative part
2836 -- up to and excluding the task body. This ensures that annotations
2837 -- referenced by the contract of an entry or subprogram body declared
2838 -- within the current protected body are available.
2839
2840 Analyze_Previous_Contracts (N);
2841
2842 Tasking_Used := True;
2843 Set_Scope (Body_Id, Current_Scope);
2844 Set_Ekind (Body_Id, E_Task_Body);
2845 Set_Etype (Body_Id, Standard_Void_Type);
2846 Spec_Id := Find_Concurrent_Spec (Body_Id);
2847
2848 -- The spec is either a task type declaration, or a single task
2849 -- declaration for which we have created an anonymous type.
2850
2851 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Task_Type then
2852 null;
2853
2854 elsif Present (Spec_Id)
2855 and then Ekind (Etype (Spec_Id)) = E_Task_Type
2856 and then not Comes_From_Source (Etype (Spec_Id))
2857 then
2858 null;
2859
2860 else
2861 Error_Msg_N ("missing specification for task body", Body_Id);
2862 return;
2863 end if;
2864
2865 if Has_Completion (Spec_Id)
2866 and then Present (Corresponding_Body (Parent (Spec_Id)))
2867 then
2868 if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
2869 Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
2870 else
2871 Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
2872 end if;
2873 end if;
2874
2875 Ref_Id := Spec_Id;
2876 Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
2877 Style.Check_Identifier (Body_Id, Spec_Id);
2878
2879 -- Deal with case of body of single task (anonymous type was created)
2880
2881 if Ekind (Spec_Id) = E_Variable then
2882 Spec_Id := Etype (Spec_Id);
2883 end if;
2884
2885 -- Set the SPARK_Mode from the current context (may be overwritten later
2886 -- with an explicit pragma).
2887
2888 Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
2889 Set_SPARK_Pragma_Inherited (Body_Id);
2890
2891 if Has_Aspects (N) then
2892 Analyze_Aspect_Specifications (N, Body_Id);
2893 end if;
2894
2895 Push_Scope (Spec_Id);
2896 Set_Corresponding_Spec (N, Spec_Id);
2897 Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
2898 Set_Has_Completion (Spec_Id);
2899 Install_Declarations (Spec_Id);
2900 Last_E := Last_Entity (Spec_Id);
2901
2902 Analyze_Declarations (Decls);
2903 Inspect_Deferred_Constant_Completion (Decls);
2904
2905 -- For visibility purposes, all entities in the body are private. Set
2906 -- First_Private_Entity accordingly, if there was no private part in the
2907 -- protected declaration.
2908
2909 if No (First_Private_Entity (Spec_Id)) then
2910 if Present (Last_E) then
2911 Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
2912 else
2913 Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
2914 end if;
2915 end if;
2916
2917 -- Mark all handlers as not suitable for local raise optimization,
2918 -- since this optimization causes difficulties in a task context.
2919
2920 if Present (Exception_Handlers (HSS)) then
2921 declare
2922 Handlr : Node_Id;
2923 begin
2924 Handlr := First (Exception_Handlers (HSS));
2925 while Present (Handlr) loop
2926 Set_Local_Raise_Not_OK (Handlr);
2927 Next (Handlr);
2928 end loop;
2929 end;
2930 end if;
2931
2932 -- Now go ahead and complete analysis of the task body
2933
2934 Analyze (HSS);
2935 Check_Completion (Body_Id);
2936 Check_References (Body_Id);
2937 Check_References (Spec_Id);
2938
2939 -- Check for entries with no corresponding accept
2940
2941 declare
2942 Ent : Entity_Id;
2943
2944 begin
2945 Ent := First_Entity (Spec_Id);
2946 while Present (Ent) loop
2947 if Is_Entry (Ent)
2948 and then not Entry_Accepted (Ent)
2949 and then Comes_From_Source (Ent)
2950 then
2951 Error_Msg_NE ("no accept for entry &??", N, Ent);
2952 end if;
2953
2954 Next_Entity (Ent);
2955 end loop;
2956 end;
2957
2958 Process_End_Label (HSS, 't', Ref_Id);
2959 End_Scope;
2960 end Analyze_Task_Body;
2961
2962 -----------------------------
2963 -- Analyze_Task_Definition --
2964 -----------------------------
2965
2966 procedure Analyze_Task_Definition (N : Node_Id) is
2967 L : Entity_Id;
2968
2969 begin
2970 Tasking_Used := True;
2971 Check_SPARK_05_Restriction ("task definition is not allowed", N);
2972
2973 if Present (Visible_Declarations (N)) then
2974 Analyze_Declarations (Visible_Declarations (N));
2975 end if;
2976
2977 if Present (Private_Declarations (N)) then
2978 L := Last_Entity (Current_Scope);
2979 Analyze_Declarations (Private_Declarations (N));
2980
2981 if Present (L) then
2982 Set_First_Private_Entity
2983 (Current_Scope, Next_Entity (L));
2984 else
2985 Set_First_Private_Entity
2986 (Current_Scope, First_Entity (Current_Scope));
2987 end if;
2988 end if;
2989
2990 Check_Max_Entries (N, Max_Task_Entries);
2991 Process_End_Label (N, 'e', Current_Scope);
2992 end Analyze_Task_Definition;
2993
2994 -----------------------------------
2995 -- Analyze_Task_Type_Declaration --
2996 -----------------------------------
2997
2998 procedure Analyze_Task_Type_Declaration (N : Node_Id) is
2999 Def_Id : constant Entity_Id := Defining_Identifier (N);
3000 T : Entity_Id;
3001
3002 begin
3003 -- Attempt to use tasking in no run time mode is not allowe. Issue hard
3004 -- error message to disable expansion which leads to crashes.
3005
3006 if Opt.No_Run_Time_Mode then
3007 Error_Msg_N ("tasking not allowed in No_Run_Time mode", N);
3008
3009 -- Otherwise soft check for no tasking restriction
3010
3011 else
3012 Check_Restriction (No_Tasking, N);
3013 end if;
3014
3015 -- Proceed ahead with analysis of task type declaration
3016
3017 Tasking_Used := True;
3018
3019 -- The sequential partition elaboration policy is supported only in the
3020 -- restricted profile.
3021
3022 if Partition_Elaboration_Policy = 'S'
3023 and then not Restricted_Profile
3024 then
3025 Error_Msg_N
3026 ("sequential elaboration supported only in restricted profile", N);
3027 end if;
3028
3029 T := Find_Type_Name (N);
3030 Generate_Definition (T);
3031
3032 -- In the case of an incomplete type, use the full view, unless it's not
3033 -- present (as can occur for an incomplete view from a limited with).
3034 -- Initialize the Corresponding_Record_Type (which overlays the Private
3035 -- Dependents field of the incomplete view).
3036
3037 if Ekind (T) = E_Incomplete_Type then
3038 if Present (Full_View (T)) then
3039 T := Full_View (T);
3040 Set_Completion_Referenced (T);
3041
3042 else
3043 Set_Ekind (T, E_Task_Type);
3044 Set_Corresponding_Record_Type (T, Empty);
3045 end if;
3046 end if;
3047
3048 Set_Ekind (T, E_Task_Type);
3049 Set_Is_First_Subtype (T, True);
3050 Set_Has_Task (T, True);
3051 Init_Size_Align (T);
3052 Set_Etype (T, T);
3053 Set_Has_Delayed_Freeze (T, True);
3054 Set_Stored_Constraint (T, No_Elist);
3055
3056 -- Set the SPARK_Mode from the current context (may be overwritten later
3057 -- with an explicit pragma).
3058
3059 Set_SPARK_Pragma (T, SPARK_Mode_Pragma);
3060 Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma);
3061 Set_SPARK_Pragma_Inherited (T);
3062 Set_SPARK_Aux_Pragma_Inherited (T);
3063
3064 Push_Scope (T);
3065
3066 if Ada_Version >= Ada_2005 then
3067 Check_Interfaces (N, T);
3068 end if;
3069
3070 if Present (Discriminant_Specifications (N)) then
3071 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3072 Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
3073 end if;
3074
3075 if Has_Discriminants (T) then
3076
3077 -- Install discriminants. Also, verify conformance of
3078 -- discriminants of previous and current view. ???
3079
3080 Install_Declarations (T);
3081 else
3082 Process_Discriminants (N);
3083 end if;
3084 end if;
3085
3086 Set_Is_Constrained (T, not Has_Discriminants (T));
3087
3088 if Has_Aspects (N) then
3089
3090 -- The task type is the full view of a private type. Analyze the
3091 -- aspects with the entity of the private type to ensure that after
3092 -- both views are exchanged, the aspect are actually associated with
3093 -- the full view.
3094
3095 if T /= Def_Id and then Is_Private_Type (Def_Id) then
3096 Analyze_Aspect_Specifications (N, T);
3097 else
3098 Analyze_Aspect_Specifications (N, Def_Id);
3099 end if;
3100 end if;
3101
3102 if Present (Task_Definition (N)) then
3103 Analyze_Task_Definition (Task_Definition (N));
3104 end if;
3105
3106 -- In the case where the task type is declared at a nested level and the
3107 -- No_Task_Hierarchy restriction applies, issue a warning that objects
3108 -- of the type will violate the restriction.
3109
3110 if Restriction_Check_Required (No_Task_Hierarchy)
3111 and then not Is_Library_Level_Entity (T)
3112 and then Comes_From_Source (T)
3113 and then not CodePeer_Mode
3114 then
3115 Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy);
3116
3117 if Error_Msg_Sloc = No_Location then
3118 Error_Msg_N
3119 ("objects of this type will violate `No_Task_Hierarchy`??", N);
3120 else
3121 Error_Msg_N
3122 ("objects of this type will violate `No_Task_Hierarchy`#??", N);
3123 end if;
3124 end if;
3125
3126 End_Scope;
3127
3128 -- Case of a completion of a private declaration
3129
3130 if T /= Def_Id and then Is_Private_Type (Def_Id) then
3131
3132 -- Deal with preelaborable initialization. Note that this processing
3133 -- is done by Process_Full_View, but as can be seen below, in this
3134 -- case the call to Process_Full_View is skipped if any serious
3135 -- errors have occurred, and we don't want to lose this check.
3136
3137 if Known_To_Have_Preelab_Init (Def_Id) then
3138 Set_Must_Have_Preelab_Init (T);
3139 end if;
3140
3141 -- Propagate invariant-related attributes from the private type to
3142 -- task type.
3143
3144 Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
3145
3146 -- Create corresponding record now, because some private dependents
3147 -- may be subtypes of the partial view.
3148
3149 -- Skip if errors are present, to prevent cascaded messages
3150
3151 if Serious_Errors_Detected = 0
3152
3153 -- Also skip if expander is not active
3154
3155 and then Expander_Active
3156 then
3157 Expand_N_Task_Type_Declaration (N);
3158 Process_Full_View (N, T, Def_Id);
3159 end if;
3160 end if;
3161 end Analyze_Task_Type_Declaration;
3162
3163 -----------------------------------
3164 -- Analyze_Terminate_Alternative --
3165 -----------------------------------
3166
3167 procedure Analyze_Terminate_Alternative (N : Node_Id) is
3168 begin
3169 Tasking_Used := True;
3170
3171 if Present (Pragmas_Before (N)) then
3172 Analyze_List (Pragmas_Before (N));
3173 end if;
3174
3175 if Present (Condition (N)) then
3176 Analyze_And_Resolve (Condition (N), Any_Boolean);
3177 end if;
3178 end Analyze_Terminate_Alternative;
3179
3180 ------------------------------
3181 -- Analyze_Timed_Entry_Call --
3182 ------------------------------
3183
3184 procedure Analyze_Timed_Entry_Call (N : Node_Id) is
3185 Trigger : constant Node_Id :=
3186 Entry_Call_Statement (Entry_Call_Alternative (N));
3187 Is_Disp_Select : Boolean := False;
3188
3189 begin
3190 Tasking_Used := True;
3191 Check_SPARK_05_Restriction ("select statement is not allowed", N);
3192 Check_Restriction (No_Select_Statements, N);
3193
3194 -- Ada 2005 (AI-345): The trigger may be a dispatching call
3195
3196 if Ada_Version >= Ada_2005 then
3197 Analyze (Trigger);
3198 Check_Triggering_Statement (Trigger, N, Is_Disp_Select);
3199 end if;
3200
3201 -- Postpone the analysis of the statements till expansion. Analyze only
3202 -- if the expander is disabled in order to catch any semantic errors.
3203
3204 if Is_Disp_Select then
3205 if not Expander_Active then
3206 Analyze (Entry_Call_Alternative (N));
3207 Analyze (Delay_Alternative (N));
3208 end if;
3209
3210 -- Regular select analysis
3211
3212 else
3213 Analyze (Entry_Call_Alternative (N));
3214 Analyze (Delay_Alternative (N));
3215 end if;
3216 end Analyze_Timed_Entry_Call;
3217
3218 ------------------------------------
3219 -- Analyze_Triggering_Alternative --
3220 ------------------------------------
3221
3222 procedure Analyze_Triggering_Alternative (N : Node_Id) is
3223 Trigger : constant Node_Id := Triggering_Statement (N);
3224
3225 begin
3226 Tasking_Used := True;
3227
3228 if Present (Pragmas_Before (N)) then
3229 Analyze_List (Pragmas_Before (N));
3230 end if;
3231
3232 Analyze (Trigger);
3233
3234 if Comes_From_Source (Trigger)
3235 and then Nkind (Trigger) not in N_Delay_Statement
3236 and then Nkind (Trigger) /= N_Entry_Call_Statement
3237 then
3238 if Ada_Version < Ada_2005 then
3239 Error_Msg_N
3240 ("triggering statement must be delay or entry call", Trigger);
3241
3242 -- Ada 2005 (AI-345): If a procedure_call_statement is used for a
3243 -- procedure_or_entry_call, the procedure_name or procedure_prefix
3244 -- of the procedure_call_statement shall denote an entry renamed by a
3245 -- procedure, or (a view of) a primitive subprogram of a limited
3246 -- interface whose first parameter is a controlling parameter.
3247
3248 elsif Nkind (Trigger) = N_Procedure_Call_Statement
3249 and then not Is_Renamed_Entry (Entity (Name (Trigger)))
3250 and then not Is_Controlling_Limited_Procedure
3251 (Entity (Name (Trigger)))
3252 then
3253 Error_Msg_N
3254 ("triggering statement must be procedure or entry call " &
3255 "or delay statement", Trigger);
3256 end if;
3257 end if;
3258
3259 if Is_Non_Empty_List (Statements (N)) then
3260 Analyze_Statements (Statements (N));
3261 end if;
3262 end Analyze_Triggering_Alternative;
3263
3264 -----------------------
3265 -- Check_Max_Entries --
3266 -----------------------
3267
3268 procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
3269 Ecount : Uint;
3270
3271 procedure Count (L : List_Id);
3272 -- Count entries in given declaration list
3273
3274 -----------
3275 -- Count --
3276 -----------
3277
3278 procedure Count (L : List_Id) is
3279 D : Node_Id;
3280
3281 begin
3282 if No (L) then
3283 return;
3284 end if;
3285
3286 D := First (L);
3287 while Present (D) loop
3288 if Nkind (D) = N_Entry_Declaration then
3289 declare
3290 DSD : constant Node_Id :=
3291 Discrete_Subtype_Definition (D);
3292
3293 begin
3294 -- If not an entry family, then just one entry
3295
3296 if No (DSD) then
3297 Ecount := Ecount + 1;
3298
3299 -- If entry family with static bounds, count entries
3300
3301 elsif Is_OK_Static_Subtype (Etype (DSD)) then
3302 declare
3303 Lo : constant Uint :=
3304 Expr_Value
3305 (Type_Low_Bound (Etype (DSD)));
3306 Hi : constant Uint :=
3307 Expr_Value
3308 (Type_High_Bound (Etype (DSD)));
3309
3310 begin
3311 if Hi >= Lo then
3312 Ecount := Ecount + Hi - Lo + 1;
3313 end if;
3314 end;
3315
3316 -- Entry family with non-static bounds
3317
3318 else
3319 -- Record an unknown count restriction, and if the
3320 -- restriction is active, post a message or warning.
3321
3322 Check_Restriction (R, D);
3323 end if;
3324 end;
3325 end if;
3326
3327 Next (D);
3328 end loop;
3329 end Count;
3330
3331 -- Start of processing for Check_Max_Entries
3332
3333 begin
3334 Ecount := Uint_0;
3335 Count (Visible_Declarations (D));
3336 Count (Private_Declarations (D));
3337
3338 if Ecount > 0 then
3339 Check_Restriction (R, D, Ecount);
3340 end if;
3341 end Check_Max_Entries;
3342
3343 ----------------------
3344 -- Check_Interfaces --
3345 ----------------------
3346
3347 procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is
3348 Iface : Node_Id;
3349 Iface_Typ : Entity_Id;
3350
3351 begin
3352 pragma Assert
3353 (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration));
3354
3355 if Present (Interface_List (N)) then
3356 Set_Is_Tagged_Type (T);
3357
3358 -- The primitive operations of a tagged synchronized type are placed
3359 -- on the Corresponding_Record for proper dispatching, but are
3360 -- attached to the synchronized type itself when expansion is
3361 -- disabled, for ASIS use.
3362
3363 Set_Direct_Primitive_Operations (T, New_Elmt_List);
3364
3365 Iface := First (Interface_List (N));
3366 while Present (Iface) loop
3367 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
3368
3369 if not Is_Interface (Iface_Typ) then
3370 Error_Msg_NE
3371 ("(Ada 2005) & must be an interface", Iface, Iface_Typ);
3372
3373 else
3374 -- Ada 2005 (AI-251): "The declaration of a specific descendant
3375 -- of an interface type freezes the interface type" RM 13.14.
3376
3377 Freeze_Before (N, Etype (Iface));
3378
3379 if Nkind (N) = N_Protected_Type_Declaration then
3380
3381 -- Ada 2005 (AI-345): Protected types can only implement
3382 -- limited, synchronized, or protected interfaces (note that
3383 -- the predicate Is_Limited_Interface includes synchronized
3384 -- and protected interfaces).
3385
3386 if Is_Task_Interface (Iface_Typ) then
3387 Error_Msg_N ("(Ada 2005) protected type cannot implement "
3388 & "a task interface", Iface);
3389
3390 elsif not Is_Limited_Interface (Iface_Typ) then
3391 Error_Msg_N ("(Ada 2005) protected type cannot implement "
3392 & "a non-limited interface", Iface);
3393 end if;
3394
3395 else pragma Assert (Nkind (N) = N_Task_Type_Declaration);
3396
3397 -- Ada 2005 (AI-345): Task types can only implement limited,
3398 -- synchronized, or task interfaces (note that the predicate
3399 -- Is_Limited_Interface includes synchronized and task
3400 -- interfaces).
3401
3402 if Is_Protected_Interface (Iface_Typ) then
3403 Error_Msg_N ("(Ada 2005) task type cannot implement a " &
3404 "protected interface", Iface);
3405
3406 elsif not Is_Limited_Interface (Iface_Typ) then
3407 Error_Msg_N ("(Ada 2005) task type cannot implement a " &
3408 "non-limited interface", Iface);
3409 end if;
3410 end if;
3411 end if;
3412
3413 Next (Iface);
3414 end loop;
3415 end if;
3416
3417 if not Has_Private_Declaration (T) then
3418 return;
3419 end if;
3420
3421 -- Additional checks on full-types associated with private type
3422 -- declarations. Search for the private type declaration.
3423
3424 declare
3425 Full_T_Ifaces : Elist_Id;
3426 Iface : Node_Id;
3427 Priv_T : Entity_Id;
3428 Priv_T_Ifaces : Elist_Id;
3429
3430 begin
3431 Priv_T := First_Entity (Scope (T));
3432 loop
3433 pragma Assert (Present (Priv_T));
3434
3435 if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then
3436 exit when Full_View (Priv_T) = T;
3437 end if;
3438
3439 Next_Entity (Priv_T);
3440 end loop;
3441
3442 -- In case of synchronized types covering interfaces the private type
3443 -- declaration must be limited.
3444
3445 if Present (Interface_List (N))
3446 and then not Is_Limited_Type (Priv_T)
3447 then
3448 Error_Msg_Sloc := Sloc (Priv_T);
3449 Error_Msg_N ("(Ada 2005) limited type declaration expected for " &
3450 "private type#", T);
3451 end if;
3452
3453 -- RM 7.3 (7.1/2): If the full view has a partial view that is
3454 -- tagged then check RM 7.3 subsidiary rules.
3455
3456 if Is_Tagged_Type (Priv_T)
3457 and then not Error_Posted (N)
3458 then
3459 -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged
3460 -- type if and only if the full type is a synchronized tagged type
3461
3462 if Is_Synchronized_Tagged_Type (Priv_T)
3463 and then not Is_Synchronized_Tagged_Type (T)
3464 then
3465 Error_Msg_N
3466 ("(Ada 2005) full view must be a synchronized tagged " &
3467 "type (RM 7.3 (7.2/2))", Priv_T);
3468
3469 elsif Is_Synchronized_Tagged_Type (T)
3470 and then not Is_Synchronized_Tagged_Type (Priv_T)
3471 then
3472 Error_Msg_N
3473 ("(Ada 2005) partial view must be a synchronized tagged " &
3474 "type (RM 7.3 (7.2/2))", T);
3475 end if;
3476
3477 -- RM 7.3 (7.3/2): The partial view shall be a descendant of an
3478 -- interface type if and only if the full type is descendant of
3479 -- the interface type.
3480
3481 if Present (Interface_List (N))
3482 or else (Is_Tagged_Type (Priv_T)
3483 and then Has_Interfaces
3484 (Priv_T, Use_Full_View => False))
3485 then
3486 if Is_Tagged_Type (Priv_T) then
3487 Collect_Interfaces
3488 (Priv_T, Priv_T_Ifaces, Use_Full_View => False);
3489 end if;
3490
3491 if Is_Tagged_Type (T) then
3492 Collect_Interfaces (T, Full_T_Ifaces);
3493 end if;
3494
3495 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
3496
3497 if Present (Iface) then
3498 Error_Msg_NE
3499 ("interface in partial view& not implemented by full "
3500 & "type (RM-2005 7.3 (7.3/2))", T, Iface);
3501 end if;
3502
3503 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
3504
3505 if Present (Iface) then
3506 Error_Msg_NE
3507 ("interface & not implemented by partial " &
3508 "view (RM-2005 7.3 (7.3/2))", T, Iface);
3509 end if;
3510 end if;
3511 end if;
3512 end;
3513 end Check_Interfaces;
3514
3515 --------------------------------
3516 -- Check_Triggering_Statement --
3517 --------------------------------
3518
3519 procedure Check_Triggering_Statement
3520 (Trigger : Node_Id;
3521 Error_Node : Node_Id;
3522 Is_Dispatching : out Boolean)
3523 is
3524 Param : Node_Id;
3525
3526 begin
3527 Is_Dispatching := False;
3528
3529 -- It is not possible to have a dispatching trigger if we are not in
3530 -- Ada 2005 mode.
3531
3532 if Ada_Version >= Ada_2005
3533 and then Nkind (Trigger) = N_Procedure_Call_Statement
3534 and then Present (Parameter_Associations (Trigger))
3535 then
3536 Param := First (Parameter_Associations (Trigger));
3537
3538 if Is_Controlling_Actual (Param)
3539 and then Is_Interface (Etype (Param))
3540 then
3541 if Is_Limited_Record (Etype (Param)) then
3542 Is_Dispatching := True;
3543 else
3544 Error_Msg_N
3545 ("dispatching operation of limited or synchronized " &
3546 "interface required (RM 9.7.2(3))!", Error_Node);
3547 end if;
3548
3549 elsif Nkind (Trigger) = N_Explicit_Dereference then
3550 Error_Msg_N
3551 ("entry call or dispatching primitive of interface required ",
3552 Trigger);
3553 end if;
3554 end if;
3555 end Check_Triggering_Statement;
3556
3557 --------------------------
3558 -- Find_Concurrent_Spec --
3559 --------------------------
3560
3561 function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
3562 Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
3563
3564 begin
3565 -- The type may have been given by an incomplete type declaration.
3566 -- Find full view now.
3567
3568 if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
3569 Spec_Id := Full_View (Spec_Id);
3570 end if;
3571
3572 return Spec_Id;
3573 end Find_Concurrent_Spec;
3574
3575 --------------------------
3576 -- Install_Declarations --
3577 --------------------------
3578
3579 procedure Install_Declarations (Spec : Entity_Id) is
3580 E : Entity_Id;
3581 Prev : Entity_Id;
3582 begin
3583 E := First_Entity (Spec);
3584 while Present (E) loop
3585 Prev := Current_Entity (E);
3586 Set_Current_Entity (E);
3587 Set_Is_Immediately_Visible (E);
3588 Set_Homonym (E, Prev);
3589 Next_Entity (E);
3590 end loop;
3591 end Install_Declarations;
3592
3593 end Sem_Ch9;