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