File : exp_ch9.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C H 9 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Errout; use Errout;
31 with Exp_Ch3; use Exp_Ch3;
32 with Exp_Ch6; use Exp_Ch6;
33 with Exp_Ch11; use Exp_Ch11;
34 with Exp_Dbug; use Exp_Dbug;
35 with Exp_Disp; use Exp_Disp;
36 with Exp_Sel; use Exp_Sel;
37 with Exp_Smem; use Exp_Smem;
38 with Exp_Tss; use Exp_Tss;
39 with Exp_Util; use Exp_Util;
40 with Freeze; use Freeze;
41 with Hostparm;
42 with Itypes; use Itypes;
43 with Namet; use Namet;
44 with Nlists; use Nlists;
45 with Nmake; use Nmake;
46 with Opt; use Opt;
47 with Restrict; use Restrict;
48 with Rident; use Rident;
49 with Rtsfind; use Rtsfind;
50 with Sem; use Sem;
51 with Sem_Aux; use Sem_Aux;
52 with Sem_Ch6; use Sem_Ch6;
53 with Sem_Ch8; use Sem_Ch8;
54 with Sem_Ch9; use Sem_Ch9;
55 with Sem_Ch11; use Sem_Ch11;
56 with Sem_Elab; use Sem_Elab;
57 with Sem_Eval; use Sem_Eval;
58 with Sem_Res; use Sem_Res;
59 with Sem_Util; use Sem_Util;
60 with Sinfo; use Sinfo;
61 with Snames; use Snames;
62 with Stand; use Stand;
63 with Stringt; use Stringt;
64 with Targparm; use Targparm;
65 with Tbuild; use Tbuild;
66 with Uintp; use Uintp;
67
68 package body Exp_Ch9 is
69
70 -- The following constant establishes the upper bound for the index of
71 -- an entry family. It is used to limit the allocated size of protected
72 -- types with defaulted discriminant of an integer type, when the bound
73 -- of some entry family depends on a discriminant. The limitation to entry
74 -- families of 128K should be reasonable in all cases, and is a documented
75 -- implementation restriction.
76
77 Entry_Family_Bound : constant Pos := 2**16;
78
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
82
83 function Actual_Index_Expression
84 (Sloc : Source_Ptr;
85 Ent : Entity_Id;
86 Index : Node_Id;
87 Tsk : Entity_Id) return Node_Id;
88 -- Compute the index position for an entry call. Tsk is the target task. If
89 -- the bounds of some entry family depend on discriminants, the expression
90 -- computed by this function uses the discriminants of the target task.
91
92 procedure Add_Object_Pointer
93 (Loc : Source_Ptr;
94 Conc_Typ : Entity_Id;
95 Decls : List_Id);
96 -- Prepend an object pointer declaration to the declaration list Decls.
97 -- This object pointer is initialized to a type conversion of the System.
98 -- Address pointer passed to entry barrier functions and entry body
99 -- procedures.
100
101 procedure Add_Formal_Renamings
102 (Spec : Node_Id;
103 Decls : List_Id;
104 Ent : Entity_Id;
105 Loc : Source_Ptr);
106 -- Create renaming declarations for the formals, inside the procedure that
107 -- implements an entry body. The renamings make the original names of the
108 -- formals accessible to gdb, and serve no other purpose.
109 -- Spec is the specification of the procedure being built.
110 -- Decls is the list of declarations to be enhanced.
111 -- Ent is the entity for the original entry body.
112
113 function Build_Accept_Body (Astat : Node_Id) return Node_Id;
114 -- Transform accept statement into a block with added exception handler.
115 -- Used both for simple accept statements and for accept alternatives in
116 -- select statements. Astat is the accept statement.
117
118 function Build_Barrier_Function
119 (N : Node_Id;
120 Ent : Entity_Id;
121 Pid : Node_Id) return Node_Id;
122 -- Build the function body returning the value of the barrier expression
123 -- for the specified entry body.
124
125 function Build_Barrier_Function_Specification
126 (Loc : Source_Ptr;
127 Def_Id : Entity_Id) return Node_Id;
128 -- Build a specification for a function implementing the protected entry
129 -- barrier of the specified entry body.
130
131 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id);
132 -- Build the body of a wrapper procedure for an entry or entry family that
133 -- has contract cases, preconditions, or postconditions. The body gathers
134 -- the executable contract items and expands them in the usual way, and
135 -- performs the entry call itself. This way preconditions are evaluated
136 -- before the call is queued. E is the entry in question, and Decl is the
137 -- enclosing synchronized type declaration at whose freeze point the
138 -- generated body is analyzed.
139
140 function Build_Corresponding_Record
141 (N : Node_Id;
142 Ctyp : Node_Id;
143 Loc : Source_Ptr) return Node_Id;
144 -- Common to tasks and protected types. Copy discriminant specifications,
145 -- build record declaration. N is the type declaration, Ctyp is the
146 -- concurrent entity (task type or protected type).
147
148 function Build_Dispatching_Tag_Check
149 (K : Entity_Id;
150 N : Node_Id) return Node_Id;
151 -- Utility to create the tree to check whether the dispatching call in
152 -- a timed entry call, a conditional entry call, or an asynchronous
153 -- transfer of control is a call to a primitive of a non-synchronized type.
154 -- K is the temporary that holds the tagged kind of the target object, and
155 -- N is the enclosing construct.
156
157 function Build_Entry_Count_Expression
158 (Concurrent_Type : Node_Id;
159 Component_List : List_Id;
160 Loc : Source_Ptr) return Node_Id;
161 -- Compute number of entries for concurrent object. This is a count of
162 -- simple entries, followed by an expression that computes the length
163 -- of the range of each entry family. A single array with that size is
164 -- allocated for each concurrent object of the type.
165
166 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
167 -- Build the function that translates the entry index in the call
168 -- (which depends on the size of entry families) into an index into the
169 -- Entry_Bodies_Array, to determine the body and barrier function used
170 -- in a protected entry call. A pointer to this function appears in every
171 -- protected object.
172
173 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
174 -- Build subprogram declaration for previous one
175
176 function Build_Lock_Free_Protected_Subprogram_Body
177 (N : Node_Id;
178 Prot_Typ : Node_Id;
179 Unprot_Spec : Node_Id) return Node_Id;
180 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is
181 -- the subprogram specification of the unprotected version of N. Transform
182 -- N such that it invokes the unprotected version of the body.
183
184 function Build_Lock_Free_Unprotected_Subprogram_Body
185 (N : Node_Id;
186 Prot_Typ : Node_Id) return Node_Id;
187 -- N denotes a subprogram body of protected type Prot_Typ. Build a version
188 -- of N where the original statements of N are synchronized through atomic
189 -- actions such as compare and exchange. Prior to invoking this routine, it
190 -- has been established that N can be implemented in a lock-free fashion.
191
192 function Build_Parameter_Block
193 (Loc : Source_Ptr;
194 Actuals : List_Id;
195 Formals : List_Id;
196 Decls : List_Id) return Entity_Id;
197 -- Generate an access type for each actual parameter in the list Actuals.
198 -- Create an encapsulating record that contains all the actuals and return
199 -- its type. Generate:
200 -- type Ann1 is access all <actual1-type>
201 -- ...
202 -- type AnnN is access all <actualN-type>
203 -- type Pnn is record
204 -- <formal1> : Ann1;
205 -- ...
206 -- <formalN> : AnnN;
207 -- end record;
208
209 function Build_Protected_Entry
210 (N : Node_Id;
211 Ent : Entity_Id;
212 Pid : Node_Id) return Node_Id;
213 -- Build the procedure implementing the statement sequence of the specified
214 -- entry body.
215
216 function Build_Protected_Entry_Specification
217 (Loc : Source_Ptr;
218 Def_Id : Entity_Id;
219 Ent_Id : Entity_Id) return Node_Id;
220 -- Build a specification for the procedure implementing the statements of
221 -- the specified entry body. Add attributes associating it with the entry
222 -- defining identifier Ent_Id.
223
224 function Build_Protected_Spec
225 (N : Node_Id;
226 Obj_Type : Entity_Id;
227 Ident : Entity_Id;
228 Unprotected : Boolean := False) return List_Id;
229 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
230 -- Subprogram_Type. Builds signature of protected subprogram, adding the
231 -- formal that corresponds to the object itself. For an access to protected
232 -- subprogram, there is no object type to specify, so the parameter has
233 -- type Address and mode In. An indirect call through such a pointer will
234 -- convert the address to a reference to the actual object. The object is
235 -- a limited record and therefore a by_reference type.
236
237 function Build_Protected_Subprogram_Body
238 (N : Node_Id;
239 Pid : Node_Id;
240 N_Op_Spec : Node_Id) return Node_Id;
241 -- This function is used to construct the protected version of a protected
242 -- subprogram. Its statement sequence first defers abort, then locks the
243 -- associated protected object, and then enters a block that contains a
244 -- call to the unprotected version of the subprogram (for details, see
245 -- Build_Unprotected_Subprogram_Body). This block statement requires a
246 -- cleanup handler that unlocks the object in all cases. For details,
247 -- see Exp_Ch7.Expand_Cleanup_Actions.
248
249 function Build_Renamed_Formal_Declaration
250 (New_F : Entity_Id;
251 Formal : Entity_Id;
252 Comp : Entity_Id;
253 Renamed_Formal : Node_Id) return Node_Id;
254 -- Create a renaming declaration for a formal, within a protected entry
255 -- body or an accept body. The renamed object is a component of the
256 -- parameter block that is a parameter in the entry call.
257 --
258 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming
259 -- does not dereference the corresponding component to prevent an illegal
260 -- use of the incomplete type (AI05-0151).
261
262 function Build_Selected_Name
263 (Prefix : Entity_Id;
264 Selector : Entity_Id;
265 Append_Char : Character := ' ') return Name_Id;
266 -- Build a name in the form of Prefix__Selector, with an optional character
267 -- appended. This is used for internal subprograms generated for operations
268 -- of protected types, including barrier functions. For the subprograms
269 -- generated for entry bodies and entry barriers, the generated name
270 -- includes a sequence number that makes names unique in the presence of
271 -- entry overloading. This is necessary because entry body procedures and
272 -- barrier functions all have the same signature.
273
274 procedure Build_Simple_Entry_Call
275 (N : Node_Id;
276 Concval : Node_Id;
277 Ename : Node_Id;
278 Index : Node_Id);
279 -- Some comments here would be useful ???
280
281 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id;
282 -- This routine constructs a specification for the procedure that we will
283 -- build for the task body for task type T. The spec has the form:
284 --
285 -- procedure tnameB (_Task : access tnameV);
286 --
287 -- where name is the character name taken from the task type entity that
288 -- is passed as the argument to the procedure, and tnameV is the task
289 -- value type that is associated with the task type.
290
291 function Build_Unprotected_Subprogram_Body
292 (N : Node_Id;
293 Pid : Node_Id) return Node_Id;
294 -- This routine constructs the unprotected version of a protected
295 -- subprogram body, which is contains all of the code in the original,
296 -- unexpanded body. This is the version of the protected subprogram that is
297 -- called from all protected operations on the same object, including the
298 -- protected version of the same subprogram.
299
300 procedure Build_Wrapper_Bodies
301 (Loc : Source_Ptr;
302 Typ : Entity_Id;
303 N : Node_Id);
304 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
305 -- record of a concurrent type. N is the insertion node where all bodies
306 -- will be placed. This routine builds the bodies of the subprograms which
307 -- serve as an indirection mechanism to overriding primitives of concurrent
308 -- types, entries and protected procedures. Any new body is analyzed.
309
310 procedure Build_Wrapper_Specs
311 (Loc : Source_Ptr;
312 Typ : Entity_Id;
313 N : in out Node_Id);
314 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
315 -- record of a concurrent type. N is the insertion node where all specs
316 -- will be placed. This routine builds the specs of the subprograms which
317 -- serve as an indirection mechanism to overriding primitives of concurrent
318 -- types, entries and protected procedures. Any new spec is analyzed.
319
320 procedure Collect_Entry_Families
321 (Loc : Source_Ptr;
322 Cdecls : List_Id;
323 Current_Node : in out Node_Id;
324 Conctyp : Entity_Id);
325 -- For each entry family in a concurrent type, create an anonymous array
326 -- type of the right size, and add a component to the corresponding_record.
327
328 function Concurrent_Object
329 (Spec_Id : Entity_Id;
330 Conc_Typ : Entity_Id) return Entity_Id;
331 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return
332 -- the entity associated with the concurrent object in the Protected_Body_
333 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity
334 -- denotes formal parameter _O, _object or _task.
335
336 function Copy_Result_Type (Res : Node_Id) return Node_Id;
337 -- Copy the result type of a function specification, when building the
338 -- internal operation corresponding to a protected function, or when
339 -- expanding an access to protected function. If the result is an anonymous
340 -- access to subprogram itself, we need to create a new signature with the
341 -- same parameter names and the same resolved types, but with new entities
342 -- for the formals.
343
344 procedure Debug_Private_Data_Declarations (Decls : List_Id);
345 -- Decls is a list which may contain the declarations created by Install_
346 -- Private_Data_Declarations. All generated entities are marked as needing
347 -- debug info and debug nodes are manually generation where necessary. This
348 -- step of the expansion must to be done after private data has been moved
349 -- to its final resting scope to ensure proper visibility of debug objects.
350
351 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id);
352 -- If control flow optimizations are suppressed, and Alt is an accept,
353 -- delay, or entry call alternative with no trailing statements, insert
354 -- a null trailing statement with the given Loc (which is the sloc of
355 -- the accept, delay, or entry call statement). There might not be any
356 -- generated code for the accept, delay, or entry call itself (the effect
357 -- of these statements is part of the general processsing done for the
358 -- enclosing selective accept, timed entry call, or asynchronous select),
359 -- and the null statement is there to carry the sloc of that statement to
360 -- the back-end for trace-based coverage analysis purposes.
361
362 procedure Extract_Dispatching_Call
363 (N : Node_Id;
364 Call_Ent : out Entity_Id;
365 Object : out Entity_Id;
366 Actuals : out List_Id;
367 Formals : out List_Id);
368 -- Given a dispatching call, extract the entity of the name of the call,
369 -- its actual dispatching object, its actual parameters and the formal
370 -- parameters of the overridden interface-level version. If the type of
371 -- the dispatching object is an access type then an explicit dereference
372 -- is returned in Object.
373
374 procedure Extract_Entry
375 (N : Node_Id;
376 Concval : out Node_Id;
377 Ename : out Node_Id;
378 Index : out Node_Id);
379 -- Given an entry call, returns the associated concurrent object, the entry
380 -- name, and the entry family index.
381
382 function Family_Offset
383 (Loc : Source_Ptr;
384 Hi : Node_Id;
385 Lo : Node_Id;
386 Ttyp : Entity_Id;
387 Cap : Boolean) return Node_Id;
388 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an
389 -- accept statement, or the upper bound in the discrete subtype of an entry
390 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent
391 -- type of the entry. If Cap is true, the result is capped according to
392 -- Entry_Family_Bound.
393
394 function Family_Size
395 (Loc : Source_Ptr;
396 Hi : Node_Id;
397 Lo : Node_Id;
398 Ttyp : Entity_Id;
399 Cap : Boolean) return Node_Id;
400 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a
401 -- family, and handle properly the superflat case. This is equivalent to
402 -- the use of 'Length on the index type, but must use Family_Offset to
403 -- handle properly the case of bounds that depend on discriminants. If
404 -- Cap is true, the result is capped according to Entry_Family_Bound.
405
406 procedure Find_Enclosing_Context
407 (N : Node_Id;
408 Context : out Node_Id;
409 Context_Id : out Entity_Id;
410 Context_Decls : out List_Id);
411 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and
412 -- Build_Master_Entity. Given an arbitrary node in the tree, find the
413 -- nearest enclosing body, block, package, or return statement and return
414 -- its constituents. Context is the enclosing construct, Context_Id is
415 -- the scope of Context_Id and Context_Decls is the declarative list of
416 -- Context.
417
418 function Index_Object (Spec_Id : Entity_Id) return Entity_Id;
419 -- Given a subprogram identifier, return the entity which is associated
420 -- with the protection entry index in the Protected_Body_Subprogram or
421 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal
422 -- parameter _E.
423
424 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
425 -- Tell whether a given subprogram cannot raise an exception
426
427 function Is_Potentially_Large_Family
428 (Base_Index : Entity_Id;
429 Conctyp : Entity_Id;
430 Lo : Node_Id;
431 Hi : Node_Id) return Boolean;
432
433 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean;
434 -- Determine whether Id is a function or a procedure and is marked as a
435 -- private primitive.
436
437 function Null_Statements (Stats : List_Id) return Boolean;
438 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END.
439 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well
440 -- to still count as null. Returns True for a null sequence. The argument
441 -- is the list of statements from the DO-END sequence.
442
443 function Parameter_Block_Pack
444 (Loc : Source_Ptr;
445 Blk_Typ : Entity_Id;
446 Actuals : List_Id;
447 Formals : List_Id;
448 Decls : List_Id;
449 Stmts : List_Id) return Entity_Id;
450 -- Set the components of the generated parameter block with the values
451 -- of the actual parameters. Generate aliased temporaries to capture the
452 -- values for types that are passed by copy. Otherwise generate a reference
453 -- to the actual's value. Return the address of the aggregate block.
454 -- Generate:
455 -- Jnn1 : alias <formal-type1>;
456 -- Jnn1 := <actual1>;
457 -- ...
458 -- P : Blk_Typ := (
459 -- Jnn1'unchecked_access;
460 -- <actual2>'reference;
461 -- ...);
462
463 function Parameter_Block_Unpack
464 (Loc : Source_Ptr;
465 P : Entity_Id;
466 Actuals : List_Id;
467 Formals : List_Id) return List_Id;
468 -- Retrieve the values of the components from the parameter block and
469 -- assign then to the original actual parameters. Generate:
470 -- <actual1> := P.<formal1>;
471 -- ...
472 -- <actualN> := P.<formalN>;
473
474 function Trivial_Accept_OK return Boolean;
475 -- If there is no DO-END block for an accept, or if the DO-END block has
476 -- only null statements, then it is possible to do the Rendezvous with much
477 -- less overhead using the Accept_Trivial routine in the run-time library.
478 -- However, this is not always a valid optimization. Whether it is valid or
479 -- not depends on the Task_Dispatching_Policy. The issue is whether a full
480 -- rescheduling action is required or not. In FIFO_Within_Priorities, such
481 -- a rescheduling is required, so this optimization is not allowed. This
482 -- function returns True if the optimization is permitted.
483
484 -----------------------------
485 -- Actual_Index_Expression --
486 -----------------------------
487
488 function Actual_Index_Expression
489 (Sloc : Source_Ptr;
490 Ent : Entity_Id;
491 Index : Node_Id;
492 Tsk : Entity_Id) return Node_Id
493 is
494 Ttyp : constant Entity_Id := Etype (Tsk);
495 Expr : Node_Id;
496 Num : Node_Id;
497 Lo : Node_Id;
498 Hi : Node_Id;
499 Prev : Entity_Id;
500 S : Node_Id;
501
502 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;
503 -- Compute difference between bounds of entry family
504
505 --------------------------
506 -- Actual_Family_Offset --
507 --------------------------
508
509 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is
510
511 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
512 -- Replace a reference to a discriminant with a selected component
513 -- denoting the discriminant of the target task.
514
515 -----------------------------
516 -- Actual_Discriminant_Ref --
517 -----------------------------
518
519 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
520 Typ : constant Entity_Id := Etype (Bound);
521 B : Node_Id;
522
523 begin
524 if not Is_Entity_Name (Bound)
525 or else Ekind (Entity (Bound)) /= E_Discriminant
526 then
527 if Nkind (Bound) = N_Attribute_Reference then
528 return Bound;
529 else
530 B := New_Copy_Tree (Bound);
531 end if;
532
533 else
534 B :=
535 Make_Selected_Component (Sloc,
536 Prefix => New_Copy_Tree (Tsk),
537 Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc));
538
539 Analyze_And_Resolve (B, Typ);
540 end if;
541
542 return
543 Make_Attribute_Reference (Sloc,
544 Attribute_Name => Name_Pos,
545 Prefix => New_Occurrence_Of (Etype (Bound), Sloc),
546 Expressions => New_List (B));
547 end Actual_Discriminant_Ref;
548
549 -- Start of processing for Actual_Family_Offset
550
551 begin
552 return
553 Make_Op_Subtract (Sloc,
554 Left_Opnd => Actual_Discriminant_Ref (Hi),
555 Right_Opnd => Actual_Discriminant_Ref (Lo));
556 end Actual_Family_Offset;
557
558 -- Start of processing for Actual_Index_Expression
559
560 begin
561 -- The queues of entries and entry families appear in textual order in
562 -- the associated record. The entry index is computed as the sum of the
563 -- number of queues for all entries that precede the designated one, to
564 -- which is added the index expression, if this expression denotes a
565 -- member of a family.
566
567 -- The following is a place holder for the count of simple entries
568
569 Num := Make_Integer_Literal (Sloc, 1);
570
571 -- We construct an expression which is a series of addition operations.
572 -- See comments in Entry_Index_Expression, which is identical in
573 -- structure.
574
575 if Present (Index) then
576 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
577
578 Expr :=
579 Make_Op_Add (Sloc,
580 Left_Opnd => Num,
581 Right_Opnd =>
582 Actual_Family_Offset (
583 Make_Attribute_Reference (Sloc,
584 Attribute_Name => Name_Pos,
585 Prefix => New_Occurrence_Of (Base_Type (S), Sloc),
586 Expressions => New_List (Relocate_Node (Index))),
587 Type_Low_Bound (S)));
588 else
589 Expr := Num;
590 end if;
591
592 -- Now add lengths of preceding entries and entry families
593
594 Prev := First_Entity (Ttyp);
595 while Chars (Prev) /= Chars (Ent)
596 or else (Ekind (Prev) /= Ekind (Ent))
597 or else not Sem_Ch6.Type_Conformant (Ent, Prev)
598 loop
599 if Ekind (Prev) = E_Entry then
600 Set_Intval (Num, Intval (Num) + 1);
601
602 elsif Ekind (Prev) = E_Entry_Family then
603 S :=
604 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
605
606 -- The need for the following full view retrieval stems from this
607 -- complex case of nested generics and tasking:
608
609 -- generic
610 -- type Formal_Index is range <>;
611 -- ...
612 -- package Outer is
613 -- type Index is private;
614 -- generic
615 -- ...
616 -- package Inner is
617 -- procedure P;
618 -- end Inner;
619 -- private
620 -- type Index is new Formal_Index range 1 .. 10;
621 -- end Outer;
622
623 -- package body Outer is
624 -- task type T is
625 -- entry Fam (Index); -- (2)
626 -- entry E;
627 -- end T;
628 -- package body Inner is -- (3)
629 -- procedure P is
630 -- begin
631 -- T.E; -- (1)
632 -- end P;
633 -- end Inner;
634 -- ...
635
636 -- We are currently building the index expression for the entry
637 -- call "T.E" (1). Part of the expansion must mention the range
638 -- of the discrete type "Index" (2) of entry family "Fam".
639
640 -- However only the private view of type "Index" is available to
641 -- the inner generic (3) because there was no prior mention of
642 -- the type inside "Inner". This visibility requirement is
643 -- implicit and cannot be detected during the construction of
644 -- the generic trees and needs special handling.
645
646 if In_Instance_Body
647 and then Is_Private_Type (S)
648 and then Present (Full_View (S))
649 then
650 S := Full_View (S);
651 end if;
652
653 Lo := Type_Low_Bound (S);
654 Hi := Type_High_Bound (S);
655
656 Expr :=
657 Make_Op_Add (Sloc,
658 Left_Opnd => Expr,
659 Right_Opnd =>
660 Make_Op_Add (Sloc,
661 Left_Opnd => Actual_Family_Offset (Hi, Lo),
662 Right_Opnd => Make_Integer_Literal (Sloc, 1)));
663
664 -- Other components are anonymous types to be ignored
665
666 else
667 null;
668 end if;
669
670 Next_Entity (Prev);
671 end loop;
672
673 return Expr;
674 end Actual_Index_Expression;
675
676 --------------------------
677 -- Add_Formal_Renamings --
678 --------------------------
679
680 procedure Add_Formal_Renamings
681 (Spec : Node_Id;
682 Decls : List_Id;
683 Ent : Entity_Id;
684 Loc : Source_Ptr)
685 is
686 Ptr : constant Entity_Id :=
687 Defining_Identifier
688 (Next (First (Parameter_Specifications (Spec))));
689 -- The name of the formal that holds the address of the parameter block
690 -- for the call.
691
692 Comp : Entity_Id;
693 Decl : Node_Id;
694 Formal : Entity_Id;
695 New_F : Entity_Id;
696 Renamed_Formal : Node_Id;
697
698 begin
699 Formal := First_Formal (Ent);
700 while Present (Formal) loop
701 Comp := Entry_Component (Formal);
702 New_F :=
703 Make_Defining_Identifier (Sloc (Formal),
704 Chars => Chars (Formal));
705 Set_Etype (New_F, Etype (Formal));
706 Set_Scope (New_F, Ent);
707
708 -- Now we set debug info needed on New_F even though it does not come
709 -- from source, so that the debugger will get the right information
710 -- for these generated names.
711
712 Set_Debug_Info_Needed (New_F);
713
714 if Ekind (Formal) = E_In_Parameter then
715 Set_Ekind (New_F, E_Constant);
716 else
717 Set_Ekind (New_F, E_Variable);
718 Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
719 end if;
720
721 Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
722
723 Renamed_Formal :=
724 Make_Selected_Component (Loc,
725 Prefix =>
726 Unchecked_Convert_To (Entry_Parameters_Type (Ent),
727 Make_Identifier (Loc, Chars (Ptr))),
728 Selector_Name => New_Occurrence_Of (Comp, Loc));
729
730 Decl :=
731 Build_Renamed_Formal_Declaration
732 (New_F, Formal, Comp, Renamed_Formal);
733
734 Append (Decl, Decls);
735 Set_Renamed_Object (Formal, New_F);
736 Next_Formal (Formal);
737 end loop;
738 end Add_Formal_Renamings;
739
740 ------------------------
741 -- Add_Object_Pointer --
742 ------------------------
743
744 procedure Add_Object_Pointer
745 (Loc : Source_Ptr;
746 Conc_Typ : Entity_Id;
747 Decls : List_Id)
748 is
749 Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ);
750 Decl : Node_Id;
751 Obj_Ptr : Node_Id;
752
753 begin
754 -- Create the renaming declaration for the Protection object of a
755 -- protected type. _Object is used by Complete_Entry_Body.
756 -- ??? An attempt to make this a renaming was unsuccessful.
757
758 -- Build the entity for the access type
759
760 Obj_Ptr :=
761 Make_Defining_Identifier (Loc,
762 New_External_Name (Chars (Rec_Typ), 'P'));
763
764 -- Generate:
765 -- _object : poVP := poVP!O;
766
767 Decl :=
768 Make_Object_Declaration (Loc,
769 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uObject),
770 Object_Definition => New_Occurrence_Of (Obj_Ptr, Loc),
771 Expression =>
772 Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO)));
773 Set_Debug_Info_Needed (Defining_Identifier (Decl));
774 Prepend_To (Decls, Decl);
775
776 -- Generate:
777 -- type poVP is access poV;
778
779 Decl :=
780 Make_Full_Type_Declaration (Loc,
781 Defining_Identifier =>
782 Obj_Ptr,
783 Type_Definition =>
784 Make_Access_To_Object_Definition (Loc,
785 Subtype_Indication =>
786 New_Occurrence_Of (Rec_Typ, Loc)));
787 Set_Debug_Info_Needed (Defining_Identifier (Decl));
788 Prepend_To (Decls, Decl);
789 end Add_Object_Pointer;
790
791 -----------------------
792 -- Build_Accept_Body --
793 -----------------------
794
795 function Build_Accept_Body (Astat : Node_Id) return Node_Id is
796 Loc : constant Source_Ptr := Sloc (Astat);
797 Stats : constant Node_Id := Handled_Statement_Sequence (Astat);
798 New_S : Node_Id;
799 Hand : Node_Id;
800 Call : Node_Id;
801 Ohandle : Node_Id;
802
803 begin
804 -- At the end of the statement sequence, Complete_Rendezvous is called.
805 -- A label skipping the Complete_Rendezvous, and all other accept
806 -- processing, has already been added for the expansion of requeue
807 -- statements. The Sloc is copied from the last statement since it
808 -- is really part of this last statement.
809
810 Call :=
811 Build_Runtime_Call
812 (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous);
813 Insert_Before (Last (Statements (Stats)), Call);
814 Analyze (Call);
815
816 -- If exception handlers are present, then append Complete_Rendezvous
817 -- calls to the handlers, and construct the required outer block. As
818 -- above, the Sloc is copied from the last statement in the sequence.
819
820 if Present (Exception_Handlers (Stats)) then
821 Hand := First (Exception_Handlers (Stats));
822 while Present (Hand) loop
823 Call :=
824 Build_Runtime_Call
825 (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous);
826 Append (Call, Statements (Hand));
827 Analyze (Call);
828 Next (Hand);
829 end loop;
830
831 New_S :=
832 Make_Handled_Sequence_Of_Statements (Loc,
833 Statements => New_List (
834 Make_Block_Statement (Loc,
835 Handled_Statement_Sequence => Stats)));
836
837 else
838 New_S := Stats;
839 end if;
840
841 -- At this stage we know that the new statement sequence does
842 -- not have an exception handler part, so we supply one to call
843 -- Exceptional_Complete_Rendezvous. This handler is
844
845 -- when all others =>
846 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
847
848 -- We handle Abort_Signal to make sure that we properly catch the abort
849 -- case and wake up the caller.
850
851 Ohandle := Make_Others_Choice (Loc);
852 Set_All_Others (Ohandle);
853
854 Set_Exception_Handlers (New_S,
855 New_List (
856 Make_Implicit_Exception_Handler (Loc,
857 Exception_Choices => New_List (Ohandle),
858
859 Statements => New_List (
860 Make_Procedure_Call_Statement (Sloc (Stats),
861 Name => New_Occurrence_Of (
862 RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)),
863 Parameter_Associations => New_List (
864 Make_Function_Call (Sloc (Stats),
865 Name =>
866 New_Occurrence_Of
867 (RTE (RE_Get_GNAT_Exception), Sloc (Stats)))))))));
868
869 Set_Parent (New_S, Astat); -- temp parent for Analyze call
870 Analyze_Exception_Handlers (Exception_Handlers (New_S));
871 Expand_Exception_Handlers (New_S);
872
873 -- Exceptional_Complete_Rendezvous must be called with abort still
874 -- deferred, which is the case for a "when all others" handler.
875
876 return New_S;
877 end Build_Accept_Body;
878
879 -----------------------------------
880 -- Build_Activation_Chain_Entity --
881 -----------------------------------
882
883 procedure Build_Activation_Chain_Entity (N : Node_Id) is
884 function Has_Activation_Chain (Stmt : Node_Id) return Boolean;
885 -- Determine whether an extended return statement has activation chain
886
887 --------------------------
888 -- Has_Activation_Chain --
889 --------------------------
890
891 function Has_Activation_Chain (Stmt : Node_Id) return Boolean is
892 Decl : Node_Id;
893
894 begin
895 Decl := First (Return_Object_Declarations (Stmt));
896 while Present (Decl) loop
897 if Nkind (Decl) = N_Object_Declaration
898 and then Chars (Defining_Identifier (Decl)) = Name_uChain
899 then
900 return True;
901 end if;
902
903 Next (Decl);
904 end loop;
905
906 return False;
907 end Has_Activation_Chain;
908
909 -- Local variables
910
911 Context : Node_Id;
912 Context_Id : Entity_Id;
913 Decls : List_Id;
914
915 -- Start of processing for Build_Activation_Chain_Entity
916
917 begin
918 -- Activation chain is never used for sequential elaboration policy, see
919 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
920
921 if Partition_Elaboration_Policy = 'S' then
922 return;
923 end if;
924
925 Find_Enclosing_Context (N, Context, Context_Id, Decls);
926
927 -- If activation chain entity has not been declared already, create one
928
929 if Nkind (Context) = N_Extended_Return_Statement
930 or else No (Activation_Chain_Entity (Context))
931 then
932 -- Since extended return statements do not store the entity of the
933 -- chain, examine the return object declarations to avoid creating
934 -- a duplicate.
935
936 if Nkind (Context) = N_Extended_Return_Statement
937 and then Has_Activation_Chain (Context)
938 then
939 return;
940 end if;
941
942 declare
943 Loc : constant Source_Ptr := Sloc (Context);
944 Chain : Entity_Id;
945 Decl : Node_Id;
946
947 begin
948 Chain := Make_Defining_Identifier (Sloc (N), Name_uChain);
949
950 -- Note: An extended return statement is not really a task
951 -- activator, but it does have an activation chain on which to
952 -- store the tasks temporarily. On successful return, the tasks
953 -- on this chain are moved to the chain passed in by the caller.
954 -- We do not build an Activation_Chain_Entity for an extended
955 -- return statement, because we do not want to build a call to
956 -- Activate_Tasks. Task activation is the responsibility of the
957 -- caller.
958
959 if Nkind (Context) /= N_Extended_Return_Statement then
960 Set_Activation_Chain_Entity (Context, Chain);
961 end if;
962
963 Decl :=
964 Make_Object_Declaration (Loc,
965 Defining_Identifier => Chain,
966 Aliased_Present => True,
967 Object_Definition =>
968 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc));
969
970 Prepend_To (Decls, Decl);
971
972 -- Ensure that _chain appears in the proper scope of the context
973
974 if Context_Id /= Current_Scope then
975 Push_Scope (Context_Id);
976 Analyze (Decl);
977 Pop_Scope;
978 else
979 Analyze (Decl);
980 end if;
981 end;
982 end if;
983 end Build_Activation_Chain_Entity;
984
985 ----------------------------
986 -- Build_Barrier_Function --
987 ----------------------------
988
989 function Build_Barrier_Function
990 (N : Node_Id;
991 Ent : Entity_Id;
992 Pid : Node_Id) return Node_Id
993 is
994 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
995 Cond : constant Node_Id := Condition (Ent_Formals);
996 Loc : constant Source_Ptr := Sloc (Cond);
997 Func_Id : constant Entity_Id := Barrier_Function (Ent);
998 Op_Decls : constant List_Id := New_List;
999 Stmt : Node_Id;
1000 Func_Body : Node_Id;
1001
1002 begin
1003 -- Add a declaration for the Protection object, renaming declarations
1004 -- for the discriminals and privals and finally a declaration for the
1005 -- entry family index (if applicable).
1006
1007 Install_Private_Data_Declarations (Sloc (N),
1008 Spec_Id => Func_Id,
1009 Conc_Typ => Pid,
1010 Body_Nod => N,
1011 Decls => Op_Decls,
1012 Barrier => True,
1013 Family => Ekind (Ent) = E_Entry_Family);
1014
1015 -- If compiling with -fpreserve-control-flow, make sure we insert an
1016 -- IF statement so that the back-end knows to generate a conditional
1017 -- branch instruction, even if the condition is just the name of a
1018 -- boolean object. Note that Expand_N_If_Statement knows to preserve
1019 -- such redundant IF statements under -fpreserve-control-flow
1020 -- (whether coming from this routine, or directly from source).
1021
1022 if Opt.Suppress_Control_Flow_Optimizations then
1023 Stmt :=
1024 Make_Implicit_If_Statement (Cond,
1025 Condition => Cond,
1026 Then_Statements => New_List (
1027 Make_Simple_Return_Statement (Loc,
1028 New_Occurrence_Of (Standard_True, Loc))),
1029
1030 Else_Statements => New_List (
1031 Make_Simple_Return_Statement (Loc,
1032 New_Occurrence_Of (Standard_False, Loc))));
1033
1034 else
1035 Stmt := Make_Simple_Return_Statement (Loc, Cond);
1036 end if;
1037
1038 -- Note: the condition in the barrier function needs to be properly
1039 -- processed for the C/Fortran boolean possibility, but this happens
1040 -- automatically since the return statement does this normalization.
1041
1042 Func_Body :=
1043 Make_Subprogram_Body (Loc,
1044 Specification =>
1045 Build_Barrier_Function_Specification (Loc,
1046 Make_Defining_Identifier (Loc, Chars (Func_Id))),
1047 Declarations => Op_Decls,
1048 Handled_Statement_Sequence =>
1049 Make_Handled_Sequence_Of_Statements (Loc,
1050 Statements => New_List (Stmt)));
1051 Set_Is_Entry_Barrier_Function (Func_Body);
1052
1053 return Func_Body;
1054 end Build_Barrier_Function;
1055
1056 ------------------------------------------
1057 -- Build_Barrier_Function_Specification --
1058 ------------------------------------------
1059
1060 function Build_Barrier_Function_Specification
1061 (Loc : Source_Ptr;
1062 Def_Id : Entity_Id) return Node_Id
1063 is
1064 begin
1065 Set_Debug_Info_Needed (Def_Id);
1066
1067 return
1068 Make_Function_Specification (Loc,
1069 Defining_Unit_Name => Def_Id,
1070 Parameter_Specifications => New_List (
1071 Make_Parameter_Specification (Loc,
1072 Defining_Identifier =>
1073 Make_Defining_Identifier (Loc, Name_uO),
1074 Parameter_Type =>
1075 New_Occurrence_Of (RTE (RE_Address), Loc)),
1076
1077 Make_Parameter_Specification (Loc,
1078 Defining_Identifier =>
1079 Make_Defining_Identifier (Loc, Name_uE),
1080 Parameter_Type =>
1081 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))),
1082
1083 Result_Definition =>
1084 New_Occurrence_Of (Standard_Boolean, Loc));
1085 end Build_Barrier_Function_Specification;
1086
1087 --------------------------
1088 -- Build_Call_With_Task --
1089 --------------------------
1090
1091 function Build_Call_With_Task
1092 (N : Node_Id;
1093 E : Entity_Id) return Node_Id
1094 is
1095 Loc : constant Source_Ptr := Sloc (N);
1096 begin
1097 return
1098 Make_Function_Call (Loc,
1099 Name => New_Occurrence_Of (E, Loc),
1100 Parameter_Associations => New_List (Concurrent_Ref (N)));
1101 end Build_Call_With_Task;
1102
1103 -----------------------------
1104 -- Build_Class_Wide_Master --
1105 -----------------------------
1106
1107 procedure Build_Class_Wide_Master (Typ : Entity_Id) is
1108 Loc : constant Source_Ptr := Sloc (Typ);
1109 Master_Id : Entity_Id;
1110 Master_Scope : Entity_Id;
1111 Name_Id : Node_Id;
1112 Related_Node : Node_Id;
1113 Ren_Decl : Node_Id;
1114
1115 begin
1116 -- Nothing to do if there is no task hierarchy
1117
1118 if Restriction_Active (No_Task_Hierarchy) then
1119 return;
1120 end if;
1121
1122 -- Find the declaration that created the access type, which is either a
1123 -- type declaration, or an object declaration with an access definition,
1124 -- in which case the type is anonymous.
1125
1126 if Is_Itype (Typ) then
1127 Related_Node := Associated_Node_For_Itype (Typ);
1128 else
1129 Related_Node := Parent (Typ);
1130 end if;
1131
1132 Master_Scope := Find_Master_Scope (Typ);
1133
1134 -- Nothing to do if the master scope already contains a _master entity.
1135 -- The only exception to this is the following scenario:
1136
1137 -- Source_Scope
1138 -- Transient_Scope_1
1139 -- _master
1140
1141 -- Transient_Scope_2
1142 -- use of master
1143
1144 -- In this case the source scope is marked as having the master entity
1145 -- even though the actual declaration appears inside an inner scope. If
1146 -- the second transient scope requires a _master, it cannot use the one
1147 -- already declared because the entity is not visible.
1148
1149 Name_Id := Make_Identifier (Loc, Name_uMaster);
1150
1151 if not Has_Master_Entity (Master_Scope)
1152 or else No (Current_Entity_In_Scope (Name_Id))
1153 then
1154 declare
1155 Master_Decl : Node_Id;
1156 begin
1157 Set_Has_Master_Entity (Master_Scope);
1158
1159 -- Generate:
1160 -- _master : constant Integer := Current_Master.all;
1161
1162 Master_Decl :=
1163 Make_Object_Declaration (Loc,
1164 Defining_Identifier =>
1165 Make_Defining_Identifier (Loc, Name_uMaster),
1166 Constant_Present => True,
1167 Object_Definition =>
1168 New_Occurrence_Of (Standard_Integer, Loc),
1169 Expression =>
1170 Make_Explicit_Dereference (Loc,
1171 New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
1172
1173 Insert_Action (Find_Hook_Context (Related_Node), Master_Decl);
1174 Analyze (Master_Decl);
1175
1176 -- Mark the containing scope as a task master. Masters associated
1177 -- with return statements are already marked at this stage (see
1178 -- Analyze_Subprogram_Body).
1179
1180 if Ekind (Current_Scope) /= E_Return_Statement then
1181 declare
1182 Par : Node_Id := Related_Node;
1183
1184 begin
1185 while Nkind (Par) /= N_Compilation_Unit loop
1186 Par := Parent (Par);
1187
1188 -- If we fall off the top, we are at the outer level,
1189 -- and the environment task is our effective master,
1190 -- so nothing to mark.
1191
1192 if Nkind_In (Par, N_Block_Statement,
1193 N_Subprogram_Body,
1194 N_Task_Body)
1195 then
1196 Set_Is_Task_Master (Par);
1197 exit;
1198 end if;
1199 end loop;
1200 end;
1201 end if;
1202 end;
1203 end if;
1204
1205 Master_Id :=
1206 Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'M'));
1207
1208 -- Generate:
1209 -- typeMnn renames _master;
1210
1211 Ren_Decl :=
1212 Make_Object_Renaming_Declaration (Loc,
1213 Defining_Identifier => Master_Id,
1214 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
1215 Name => Name_Id);
1216
1217 Insert_Action (Related_Node, Ren_Decl);
1218
1219 Set_Master_Id (Typ, Master_Id);
1220 end Build_Class_Wide_Master;
1221
1222 ----------------------------
1223 -- Build_Contract_Wrapper --
1224 ----------------------------
1225
1226 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id) is
1227 Conc_Typ : constant Entity_Id := Scope (E);
1228 Loc : constant Source_Ptr := Sloc (E);
1229
1230 procedure Add_Discriminant_Renamings
1231 (Obj_Id : Entity_Id;
1232 Decls : List_Id);
1233 -- Add renaming declarations for all discriminants of concurrent type
1234 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
1235 -- represents the concurrent object.
1236
1237 procedure Add_Matching_Formals
1238 (Formals : List_Id;
1239 Actuals : in out List_Id);
1240 -- Add formal parameters that match those of entry E to list Formals.
1241 -- The routine also adds matching actuals for the new formals to list
1242 -- Actuals.
1243
1244 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id);
1245 -- Relocate pragma Prag to list To. The routine creates a new list if
1246 -- To does not exist.
1247
1248 --------------------------------
1249 -- Add_Discriminant_Renamings --
1250 --------------------------------
1251
1252 procedure Add_Discriminant_Renamings
1253 (Obj_Id : Entity_Id;
1254 Decls : List_Id)
1255 is
1256 Discr : Entity_Id;
1257
1258 begin
1259 -- Inspect the discriminants of the concurrent type and generate a
1260 -- renaming for each one.
1261
1262 if Has_Discriminants (Conc_Typ) then
1263 Discr := First_Discriminant (Conc_Typ);
1264 while Present (Discr) loop
1265 Prepend_To (Decls,
1266 Make_Object_Renaming_Declaration (Loc,
1267 Defining_Identifier =>
1268 Make_Defining_Identifier (Loc, Chars (Discr)),
1269 Subtype_Mark =>
1270 New_Occurrence_Of (Etype (Discr), Loc),
1271 Name =>
1272 Make_Selected_Component (Loc,
1273 Prefix => New_Occurrence_Of (Obj_Id, Loc),
1274 Selector_Name =>
1275 Make_Identifier (Loc, Chars (Discr)))));
1276
1277 Next_Discriminant (Discr);
1278 end loop;
1279 end if;
1280 end Add_Discriminant_Renamings;
1281
1282 --------------------------
1283 -- Add_Matching_Formals --
1284 --------------------------
1285
1286 procedure Add_Matching_Formals
1287 (Formals : List_Id;
1288 Actuals : in out List_Id)
1289 is
1290 Formal : Entity_Id;
1291 New_Formal : Entity_Id;
1292
1293 begin
1294 -- Inspect the formal parameters of the entry and generate a new
1295 -- matching formal with the same name for the wrapper. A reference
1296 -- to the new formal becomes an actual in the entry call.
1297
1298 Formal := First_Formal (E);
1299 while Present (Formal) loop
1300 New_Formal := Make_Defining_Identifier (Loc, Chars (Formal));
1301 Append_To (Formals,
1302 Make_Parameter_Specification (Loc,
1303 Defining_Identifier => New_Formal,
1304 In_Present => In_Present (Parent (Formal)),
1305 Out_Present => Out_Present (Parent (Formal)),
1306 Parameter_Type =>
1307 New_Occurrence_Of (Etype (Formal), Loc)));
1308
1309 if No (Actuals) then
1310 Actuals := New_List;
1311 end if;
1312
1313 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
1314 Next_Formal (Formal);
1315 end loop;
1316 end Add_Matching_Formals;
1317
1318 ---------------------
1319 -- Transfer_Pragma --
1320 ---------------------
1321
1322 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id) is
1323 New_Prag : Node_Id;
1324
1325 begin
1326 if No (To) then
1327 To := New_List;
1328 end if;
1329
1330 New_Prag := Relocate_Node (Prag);
1331
1332 Set_Analyzed (New_Prag, False);
1333 Append (New_Prag, To);
1334 end Transfer_Pragma;
1335
1336 -- Local variables
1337
1338 Items : constant Node_Id := Contract (E);
1339 Actuals : List_Id := No_List;
1340 Call : Node_Id;
1341 Call_Nam : Node_Id;
1342 Decls : List_Id := No_List;
1343 Formals : List_Id;
1344 Has_Pragma : Boolean := False;
1345 Index_Id : Entity_Id;
1346 Obj_Id : Entity_Id;
1347 Prag : Node_Id;
1348 Wrapper_Id : Entity_Id;
1349
1350 -- Start of processing for Build_Contract_Wrapper
1351
1352 begin
1353 -- This routine generates a specialized wrapper for a protected or task
1354 -- entry [family] which implements precondition/postcondition semantics.
1355 -- Preconditions and case guards of contract cases are checked before
1356 -- the protected action or rendezvous takes place. Postconditions and
1357 -- consequences of contract cases are checked after the protected action
1358 -- or rendezvous takes place. The structure of the generated wrapper is
1359 -- as follows:
1360
1361 -- procedure Wrapper
1362 -- (Obj_Id : Conc_Typ; -- concurrent object
1363 -- [Index : Index_Typ;] -- index of entry family
1364 -- [Formal_1 : ...; -- parameters of original entry
1365 -- Formal_N : ...])
1366 -- is
1367 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant
1368 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings
1369
1370 -- <precondition checks>
1371 -- <case guard checks>
1372
1373 -- procedure _Postconditions is
1374 -- begin
1375 -- <postcondition checks>
1376 -- <consequence checks>
1377 -- end _Postconditions;
1378
1379 -- begin
1380 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]);
1381 -- _Postconditions;
1382 -- end Wrapper;
1383
1384 -- Create the wrapper only when the entry has at least one executable
1385 -- contract item such as contract cases, precondition or postcondition.
1386
1387 if Present (Items) then
1388
1389 -- Inspect the list of pre/postconditions and transfer all available
1390 -- pragmas to the declarative list of the wrapper.
1391
1392 Prag := Pre_Post_Conditions (Items);
1393 while Present (Prag) loop
1394 if Nam_In (Pragma_Name (Prag), Name_Postcondition,
1395 Name_Precondition)
1396 and then Is_Checked (Prag)
1397 then
1398 Has_Pragma := True;
1399 Transfer_Pragma (Prag, To => Decls);
1400 end if;
1401
1402 Prag := Next_Pragma (Prag);
1403 end loop;
1404
1405 -- Inspect the list of test/contract cases and transfer only contract
1406 -- cases pragmas to the declarative part of the wrapper.
1407
1408 Prag := Contract_Test_Cases (Items);
1409 while Present (Prag) loop
1410 if Pragma_Name (Prag) = Name_Contract_Cases
1411 and then Is_Checked (Prag)
1412 then
1413 Has_Pragma := True;
1414 Transfer_Pragma (Prag, To => Decls);
1415 end if;
1416
1417 Prag := Next_Pragma (Prag);
1418 end loop;
1419 end if;
1420
1421 -- The entry lacks executable contract items and a wrapper is not needed
1422
1423 if not Has_Pragma then
1424 return;
1425 end if;
1426
1427 -- Create the profile of the wrapper. The first formal parameter is the
1428 -- concurrent object.
1429
1430 Obj_Id :=
1431 Make_Defining_Identifier (Loc,
1432 Chars => New_External_Name (Chars (Conc_Typ), 'A'));
1433
1434 Formals := New_List (
1435 Make_Parameter_Specification (Loc,
1436 Defining_Identifier => Obj_Id,
1437 Out_Present => True,
1438 In_Present => True,
1439 Parameter_Type => New_Occurrence_Of (Conc_Typ, Loc)));
1440
1441 -- Construct the call to the original entry. The call will be gradually
1442 -- augmented with an optional entry index and extra parameters.
1443
1444 Call_Nam :=
1445 Make_Selected_Component (Loc,
1446 Prefix => New_Occurrence_Of (Obj_Id, Loc),
1447 Selector_Name => New_Occurrence_Of (E, Loc));
1448
1449 -- When creating a wrapper for an entry family, the second formal is the
1450 -- entry index.
1451
1452 if Ekind (E) = E_Entry_Family then
1453 Index_Id := Make_Defining_Identifier (Loc, Name_I);
1454
1455 Append_To (Formals,
1456 Make_Parameter_Specification (Loc,
1457 Defining_Identifier => Index_Id,
1458 Parameter_Type =>
1459 New_Occurrence_Of (Entry_Index_Type (E), Loc)));
1460
1461 -- The call to the original entry becomes an indexed component to
1462 -- accommodate the entry index.
1463
1464 Call_Nam :=
1465 Make_Indexed_Component (Loc,
1466 Prefix => Call_Nam,
1467 Expressions => New_List (New_Occurrence_Of (Index_Id, Loc)));
1468 end if;
1469
1470 -- Add formal parameters to match those of the entry and build actuals
1471 -- for the entry call.
1472
1473 Add_Matching_Formals (Formals, Actuals);
1474
1475 Call :=
1476 Make_Procedure_Call_Statement (Loc,
1477 Name => Call_Nam,
1478 Parameter_Associations => Actuals);
1479
1480 -- Add renaming declarations for the discriminants of the enclosing type
1481 -- as the various contract items may reference them.
1482
1483 Add_Discriminant_Renamings (Obj_Id, Decls);
1484
1485 Wrapper_Id :=
1486 Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E'));
1487 Set_Contract_Wrapper (E, Wrapper_Id);
1488
1489 -- The wrapper body is analyzed when the enclosing type is frozen
1490
1491 Append_Freeze_Action (Defining_Entity (Decl),
1492 Make_Subprogram_Body (Loc,
1493 Specification =>
1494 Make_Procedure_Specification (Loc,
1495 Defining_Unit_Name => Wrapper_Id,
1496 Parameter_Specifications => Formals),
1497 Declarations => Decls,
1498 Handled_Statement_Sequence =>
1499 Make_Handled_Sequence_Of_Statements (Loc,
1500 Statements => New_List (Call))));
1501 end Build_Contract_Wrapper;
1502
1503 --------------------------------
1504 -- Build_Corresponding_Record --
1505 --------------------------------
1506
1507 function Build_Corresponding_Record
1508 (N : Node_Id;
1509 Ctyp : Entity_Id;
1510 Loc : Source_Ptr) return Node_Id
1511 is
1512 Rec_Ent : constant Entity_Id :=
1513 Make_Defining_Identifier
1514 (Loc, New_External_Name (Chars (Ctyp), 'V'));
1515 Disc : Entity_Id;
1516 Dlist : List_Id;
1517 New_Disc : Entity_Id;
1518 Cdecls : List_Id;
1519
1520 begin
1521 Set_Corresponding_Record_Type (Ctyp, Rec_Ent);
1522 Set_Ekind (Rec_Ent, E_Record_Type);
1523 Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp));
1524 Set_Is_Concurrent_Record_Type (Rec_Ent, True);
1525 Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp);
1526 Set_Stored_Constraint (Rec_Ent, No_Elist);
1527 Cdecls := New_List;
1528
1529 -- Use discriminals to create list of discriminants for record, and
1530 -- create new discriminals for use in default expressions, etc. It is
1531 -- worth noting that a task discriminant gives rise to 5 entities;
1532
1533 -- a) The original discriminant.
1534 -- b) The discriminal for use in the task.
1535 -- c) The discriminant of the corresponding record.
1536 -- d) The discriminal for the init proc of the corresponding record.
1537 -- e) The local variable that renames the discriminant in the procedure
1538 -- for the task body.
1539
1540 -- In fact the discriminals b) are used in the renaming declarations
1541 -- for e). See details in einfo (Handling of Discriminants).
1542
1543 if Present (Discriminant_Specifications (N)) then
1544 Dlist := New_List;
1545 Disc := First_Discriminant (Ctyp);
1546
1547 while Present (Disc) loop
1548 New_Disc := CR_Discriminant (Disc);
1549
1550 Append_To (Dlist,
1551 Make_Discriminant_Specification (Loc,
1552 Defining_Identifier => New_Disc,
1553 Discriminant_Type =>
1554 New_Occurrence_Of (Etype (Disc), Loc),
1555 Expression =>
1556 New_Copy (Discriminant_Default_Value (Disc))));
1557
1558 Next_Discriminant (Disc);
1559 end loop;
1560
1561 else
1562 Dlist := No_List;
1563 end if;
1564
1565 -- Now we can construct the record type declaration. Note that this
1566 -- record is "limited tagged". It is "limited" to reflect the underlying
1567 -- limitedness of the task or protected object that it represents, and
1568 -- ensuring for example that it is properly passed by reference. It is
1569 -- "tagged" to give support to dispatching calls through interfaces. We
1570 -- propagate here the list of interfaces covered by the concurrent type
1571 -- (Ada 2005: AI-345).
1572
1573 return
1574 Make_Full_Type_Declaration (Loc,
1575 Defining_Identifier => Rec_Ent,
1576 Discriminant_Specifications => Dlist,
1577 Type_Definition =>
1578 Make_Record_Definition (Loc,
1579 Component_List =>
1580 Make_Component_List (Loc, Component_Items => Cdecls),
1581 Tagged_Present =>
1582 Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp),
1583 Interface_List => Interface_List (N),
1584 Limited_Present => True));
1585 end Build_Corresponding_Record;
1586
1587 ---------------------------------
1588 -- Build_Dispatching_Tag_Check --
1589 ---------------------------------
1590
1591 function Build_Dispatching_Tag_Check
1592 (K : Entity_Id;
1593 N : Node_Id) return Node_Id
1594 is
1595 Loc : constant Source_Ptr := Sloc (N);
1596
1597 begin
1598 return
1599 Make_Op_Or (Loc,
1600 Make_Op_Eq (Loc,
1601 Left_Opnd =>
1602 New_Occurrence_Of (K, Loc),
1603 Right_Opnd =>
1604 New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc)),
1605
1606 Make_Op_Eq (Loc,
1607 Left_Opnd =>
1608 New_Occurrence_Of (K, Loc),
1609 Right_Opnd =>
1610 New_Occurrence_Of (RTE (RE_TK_Tagged), Loc)));
1611 end Build_Dispatching_Tag_Check;
1612
1613 ----------------------------------
1614 -- Build_Entry_Count_Expression --
1615 ----------------------------------
1616
1617 function Build_Entry_Count_Expression
1618 (Concurrent_Type : Node_Id;
1619 Component_List : List_Id;
1620 Loc : Source_Ptr) return Node_Id
1621 is
1622 Eindx : Nat;
1623 Ent : Entity_Id;
1624 Ecount : Node_Id;
1625 Comp : Node_Id;
1626 Lo : Node_Id;
1627 Hi : Node_Id;
1628 Typ : Entity_Id;
1629 Large : Boolean;
1630
1631 begin
1632 -- Count number of non-family entries
1633
1634 Eindx := 0;
1635 Ent := First_Entity (Concurrent_Type);
1636 while Present (Ent) loop
1637 if Ekind (Ent) = E_Entry then
1638 Eindx := Eindx + 1;
1639 end if;
1640
1641 Next_Entity (Ent);
1642 end loop;
1643
1644 Ecount := Make_Integer_Literal (Loc, Eindx);
1645
1646 -- Loop through entry families building the addition nodes
1647
1648 Ent := First_Entity (Concurrent_Type);
1649 Comp := First (Component_List);
1650 while Present (Ent) loop
1651 if Ekind (Ent) = E_Entry_Family then
1652 while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop
1653 Next (Comp);
1654 end loop;
1655
1656 Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
1657 Hi := Type_High_Bound (Typ);
1658 Lo := Type_Low_Bound (Typ);
1659 Large := Is_Potentially_Large_Family
1660 (Base_Type (Typ), Concurrent_Type, Lo, Hi);
1661 Ecount :=
1662 Make_Op_Add (Loc,
1663 Left_Opnd => Ecount,
1664 Right_Opnd =>
1665 Family_Size (Loc, Hi, Lo, Concurrent_Type, Large));
1666 end if;
1667
1668 Next_Entity (Ent);
1669 end loop;
1670
1671 return Ecount;
1672 end Build_Entry_Count_Expression;
1673
1674 -----------------------
1675 -- Build_Entry_Names --
1676 -----------------------
1677
1678 procedure Build_Entry_Names
1679 (Obj_Ref : Node_Id;
1680 Obj_Typ : Entity_Id;
1681 Stmts : List_Id)
1682 is
1683 Loc : constant Source_Ptr := Sloc (Obj_Ref);
1684 Data : Entity_Id := Empty;
1685 Index : Entity_Id := Empty;
1686 Typ : Entity_Id := Obj_Typ;
1687
1688 procedure Build_Entry_Name (Comp_Id : Entity_Id);
1689 -- Given an entry [family], create a static string which denotes the
1690 -- name of Comp_Id and assign it to the underlying data structure which
1691 -- contains the entry names of a concurrent object.
1692
1693 function Object_Reference return Node_Id;
1694 -- Return a reference to field _object or _task_id depending on the
1695 -- concurrent object being processed.
1696
1697 ----------------------
1698 -- Build_Entry_Name --
1699 ----------------------
1700
1701 procedure Build_Entry_Name (Comp_Id : Entity_Id) is
1702 function Build_Range (Def : Node_Id) return Node_Id;
1703 -- Given a discrete subtype definition of an entry family, generate a
1704 -- range node which covers the range of Def's type.
1705
1706 procedure Create_Index_And_Data;
1707 -- Generate the declarations of variables Index and Data. Subsequent
1708 -- calls do nothing.
1709
1710 function Increment_Index return Node_Id;
1711 -- Increment the index used in the assignment of string names to the
1712 -- Data array.
1713
1714 function Name_Declaration (Def_Id : Entity_Id) return Node_Id;
1715 -- Given the name of a temporary variable, create the following
1716 -- declaration for it:
1717 --
1718 -- Def_Id : aliased constant String := <String_Name_From_Buffer>;
1719
1720 function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id;
1721 -- Given the name of a temporary variable, place it in the array of
1722 -- string names. Generate:
1723 --
1724 -- Data (Index) := Def_Id'Unchecked_Access;
1725
1726 -----------------
1727 -- Build_Range --
1728 -----------------
1729
1730 function Build_Range (Def : Node_Id) return Node_Id is
1731 High : Node_Id := Type_High_Bound (Etype (Def));
1732 Low : Node_Id := Type_Low_Bound (Etype (Def));
1733
1734 begin
1735 -- If a bound references a discriminant, generate an identifier
1736 -- with the same name. Resolution will map it to the formals of
1737 -- the init proc.
1738
1739 if Is_Entity_Name (Low)
1740 and then Ekind (Entity (Low)) = E_Discriminant
1741 then
1742 Low :=
1743 Make_Selected_Component (Loc,
1744 Prefix => New_Copy_Tree (Obj_Ref),
1745 Selector_Name => Make_Identifier (Loc, Chars (Low)));
1746 else
1747 Low := New_Copy_Tree (Low);
1748 end if;
1749
1750 if Is_Entity_Name (High)
1751 and then Ekind (Entity (High)) = E_Discriminant
1752 then
1753 High :=
1754 Make_Selected_Component (Loc,
1755 Prefix => New_Copy_Tree (Obj_Ref),
1756 Selector_Name => Make_Identifier (Loc, Chars (High)));
1757 else
1758 High := New_Copy_Tree (High);
1759 end if;
1760
1761 return
1762 Make_Range (Loc,
1763 Low_Bound => Low,
1764 High_Bound => High);
1765 end Build_Range;
1766
1767 ---------------------------
1768 -- Create_Index_And_Data --
1769 ---------------------------
1770
1771 procedure Create_Index_And_Data is
1772 begin
1773 if No (Index) and then No (Data) then
1774 declare
1775 Count : RE_Id;
1776 Data_Typ : RE_Id;
1777 Size : Entity_Id;
1778
1779 begin
1780 if Is_Protected_Type (Typ) then
1781 Count := RO_PE_Number_Of_Entries;
1782 Data_Typ := RE_Protected_Entry_Names_Array;
1783 else
1784 Count := RO_ST_Number_Of_Entries;
1785 Data_Typ := RE_Task_Entry_Names_Array;
1786 end if;
1787
1788 -- Step 1: Generate the declaration of the index variable:
1789
1790 -- Index : Entry_Index := 1;
1791
1792 Index := Make_Temporary (Loc, 'I');
1793
1794 Append_To (Stmts,
1795 Make_Object_Declaration (Loc,
1796 Defining_Identifier => Index,
1797 Object_Definition =>
1798 New_Occurrence_Of (RTE (RE_Entry_Index), Loc),
1799 Expression => Make_Integer_Literal (Loc, 1)));
1800
1801 -- Step 2: Generate the declaration of an array to house all
1802 -- names:
1803
1804 -- Size : constant Entry_Index := <Count> (Obj_Ref);
1805 -- Data : aliased <Data_Typ> := (1 .. Size => null);
1806
1807 Size := Make_Temporary (Loc, 'S');
1808
1809 Append_To (Stmts,
1810 Make_Object_Declaration (Loc,
1811 Defining_Identifier => Size,
1812 Constant_Present => True,
1813 Object_Definition =>
1814 New_Occurrence_Of (RTE (RE_Entry_Index), Loc),
1815 Expression =>
1816 Make_Function_Call (Loc,
1817 Name =>
1818 New_Occurrence_Of (RTE (Count), Loc),
1819 Parameter_Associations =>
1820 New_List (Object_Reference))));
1821
1822 Data := Make_Temporary (Loc, 'A');
1823
1824 Append_To (Stmts,
1825 Make_Object_Declaration (Loc,
1826 Defining_Identifier => Data,
1827 Aliased_Present => True,
1828 Object_Definition =>
1829 New_Occurrence_Of (RTE (Data_Typ), Loc),
1830 Expression =>
1831 Make_Aggregate (Loc,
1832 Component_Associations => New_List (
1833 Make_Component_Association (Loc,
1834 Choices => New_List (
1835 Make_Range (Loc,
1836 Low_Bound =>
1837 Make_Integer_Literal (Loc, 1),
1838 High_Bound =>
1839 New_Occurrence_Of (Size, Loc))),
1840 Expression => Make_Null (Loc))))));
1841 end;
1842 end if;
1843 end Create_Index_And_Data;
1844
1845 ---------------------
1846 -- Increment_Index --
1847 ---------------------
1848
1849 function Increment_Index return Node_Id is
1850 begin
1851 return
1852 Make_Assignment_Statement (Loc,
1853 Name => New_Occurrence_Of (Index, Loc),
1854 Expression =>
1855 Make_Op_Add (Loc,
1856 Left_Opnd => New_Occurrence_Of (Index, Loc),
1857 Right_Opnd => Make_Integer_Literal (Loc, 1)));
1858 end Increment_Index;
1859
1860 ----------------------
1861 -- Name_Declaration --
1862 ----------------------
1863
1864 function Name_Declaration (Def_Id : Entity_Id) return Node_Id is
1865 begin
1866 return
1867 Make_Object_Declaration (Loc,
1868 Defining_Identifier => Def_Id,
1869 Aliased_Present => True,
1870 Constant_Present => True,
1871 Object_Definition =>
1872 New_Occurrence_Of (Standard_String, Loc),
1873 Expression =>
1874 Make_String_Literal (Loc, String_From_Name_Buffer));
1875 end Name_Declaration;
1876
1877 --------------------
1878 -- Set_Entry_Name --
1879 --------------------
1880
1881 function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id is
1882 begin
1883 return
1884 Make_Assignment_Statement (Loc,
1885 Name =>
1886 Make_Indexed_Component (Loc,
1887 Prefix => New_Occurrence_Of (Data, Loc),
1888 Expressions => New_List (New_Occurrence_Of (Index, Loc))),
1889
1890 Expression =>
1891 Make_Attribute_Reference (Loc,
1892 Prefix => New_Occurrence_Of (Def_Id, Loc),
1893 Attribute_Name => Name_Unchecked_Access));
1894 end Set_Entry_Name;
1895
1896 -- Local variables
1897
1898 Temp_Id : Entity_Id;
1899 Subt_Def : Node_Id;
1900
1901 -- Start of processing for Build_Entry_Name
1902
1903 begin
1904 if Ekind (Comp_Id) = E_Entry_Family then
1905 Subt_Def := Discrete_Subtype_Definition (Parent (Comp_Id));
1906
1907 Create_Index_And_Data;
1908
1909 -- Step 1: Create the string name of the entry family.
1910 -- Generate:
1911 -- Temp : aliased constant String := "name ()";
1912
1913 Temp_Id := Make_Temporary (Loc, 'S');
1914 Get_Name_String (Chars (Comp_Id));
1915 Add_Char_To_Name_Buffer (' ');
1916 Add_Char_To_Name_Buffer ('(');
1917 Add_Char_To_Name_Buffer (')');
1918
1919 Append_To (Stmts, Name_Declaration (Temp_Id));
1920
1921 -- Generate:
1922 -- for Member in Family_Low .. Family_High loop
1923 -- Set_Entry_Name (...);
1924 -- Index := Index + 1;
1925 -- end loop;
1926
1927 Append_To (Stmts,
1928 Make_Loop_Statement (Loc,
1929 Iteration_Scheme =>
1930 Make_Iteration_Scheme (Loc,
1931 Loop_Parameter_Specification =>
1932 Make_Loop_Parameter_Specification (Loc,
1933 Defining_Identifier =>
1934 Make_Temporary (Loc, 'L'),
1935 Discrete_Subtype_Definition =>
1936 Build_Range (Subt_Def))),
1937
1938 Statements => New_List (
1939 Set_Entry_Name (Temp_Id),
1940 Increment_Index),
1941 End_Label => Empty));
1942
1943 -- Entry
1944
1945 else
1946 Create_Index_And_Data;
1947
1948 -- Step 1: Create the string name of the entry. Generate:
1949 -- Temp : aliased constant String := "name";
1950
1951 Temp_Id := Make_Temporary (Loc, 'S');
1952 Get_Name_String (Chars (Comp_Id));
1953
1954 Append_To (Stmts, Name_Declaration (Temp_Id));
1955
1956 -- Step 2: Associate the string name with the underlying data
1957 -- structure.
1958
1959 Append_To (Stmts, Set_Entry_Name (Temp_Id));
1960 Append_To (Stmts, Increment_Index);
1961 end if;
1962 end Build_Entry_Name;
1963
1964 ----------------------
1965 -- Object_Reference --
1966 ----------------------
1967
1968 function Object_Reference return Node_Id is
1969 Conc_Typ : constant Entity_Id := Corresponding_Record_Type (Typ);
1970 Field : Name_Id;
1971 Ref : Node_Id;
1972
1973 begin
1974 if Is_Protected_Type (Typ) then
1975 Field := Name_uObject;
1976 else
1977 Field := Name_uTask_Id;
1978 end if;
1979
1980 Ref :=
1981 Make_Selected_Component (Loc,
1982 Prefix =>
1983 Unchecked_Convert_To (Conc_Typ, New_Copy_Tree (Obj_Ref)),
1984 Selector_Name => Make_Identifier (Loc, Field));
1985
1986 if Is_Protected_Type (Typ) then
1987 Ref :=
1988 Make_Attribute_Reference (Loc,
1989 Prefix => Ref,
1990 Attribute_Name => Name_Unchecked_Access);
1991 end if;
1992
1993 return Ref;
1994 end Object_Reference;
1995
1996 -- Local variables
1997
1998 Comp : Node_Id;
1999 Proc : RE_Id;
2000
2001 -- Start of processing for Build_Entry_Names
2002
2003 begin
2004 -- Retrieve the original concurrent type
2005
2006 if Is_Concurrent_Record_Type (Typ) then
2007 Typ := Corresponding_Concurrent_Type (Typ);
2008 end if;
2009
2010 pragma Assert (Is_Concurrent_Type (Typ));
2011
2012 -- Nothing to do if the type has no entries
2013
2014 if not Has_Entries (Typ) then
2015 return;
2016 end if;
2017
2018 -- Avoid generating entry names for a protected type with only one entry
2019
2020 if Is_Protected_Type (Typ)
2021 and then Find_Protection_Type (Base_Type (Typ)) /=
2022 RTE (RE_Protection_Entries)
2023 then
2024 return;
2025 end if;
2026
2027 -- Step 1: Populate the array with statically generated strings denoting
2028 -- entries and entry family names.
2029
2030 Comp := First_Entity (Typ);
2031 while Present (Comp) loop
2032 if Comes_From_Source (Comp)
2033 and then Ekind_In (Comp, E_Entry, E_Entry_Family)
2034 then
2035 Build_Entry_Name (Comp);
2036 end if;
2037
2038 Next_Entity (Comp);
2039 end loop;
2040
2041 -- Step 2: Associate the array with the related concurrent object:
2042
2043 -- Set_Entry_Names (Obj_Ref, <Data>'Unchecked_Access);
2044
2045 if Present (Data) then
2046 if Is_Protected_Type (Typ) then
2047 Proc := RO_PE_Set_Entry_Names;
2048 else
2049 Proc := RO_ST_Set_Entry_Names;
2050 end if;
2051
2052 Append_To (Stmts,
2053 Make_Procedure_Call_Statement (Loc,
2054 Name => New_Occurrence_Of (RTE (Proc), Loc),
2055 Parameter_Associations => New_List (
2056 Object_Reference,
2057 Make_Attribute_Reference (Loc,
2058 Prefix => New_Occurrence_Of (Data, Loc),
2059 Attribute_Name => Name_Unchecked_Access))));
2060 end if;
2061 end Build_Entry_Names;
2062
2063 ---------------------------
2064 -- Build_Parameter_Block --
2065 ---------------------------
2066
2067 function Build_Parameter_Block
2068 (Loc : Source_Ptr;
2069 Actuals : List_Id;
2070 Formals : List_Id;
2071 Decls : List_Id) return Entity_Id
2072 is
2073 Actual : Entity_Id;
2074 Comp_Nam : Node_Id;
2075 Comps : List_Id;
2076 Formal : Entity_Id;
2077 Has_Comp : Boolean := False;
2078 Rec_Nam : Node_Id;
2079
2080 begin
2081 Actual := First (Actuals);
2082 Comps := New_List;
2083 Formal := Defining_Identifier (First (Formals));
2084
2085 while Present (Actual) loop
2086 if not Is_Controlling_Actual (Actual) then
2087
2088 -- Generate:
2089 -- type Ann is access all <actual-type>
2090
2091 Comp_Nam := Make_Temporary (Loc, 'A');
2092 Set_Is_Param_Block_Component_Type (Comp_Nam);
2093
2094 Append_To (Decls,
2095 Make_Full_Type_Declaration (Loc,
2096 Defining_Identifier => Comp_Nam,
2097 Type_Definition =>
2098 Make_Access_To_Object_Definition (Loc,
2099 All_Present => True,
2100 Constant_Present => Ekind (Formal) = E_In_Parameter,
2101 Subtype_Indication =>
2102 New_Occurrence_Of (Etype (Actual), Loc))));
2103
2104 -- Generate:
2105 -- Param : Ann;
2106
2107 Append_To (Comps,
2108 Make_Component_Declaration (Loc,
2109 Defining_Identifier =>
2110 Make_Defining_Identifier (Loc, Chars (Formal)),
2111 Component_Definition =>
2112 Make_Component_Definition (Loc,
2113 Aliased_Present =>
2114 False,
2115 Subtype_Indication =>
2116 New_Occurrence_Of (Comp_Nam, Loc))));
2117
2118 Has_Comp := True;
2119 end if;
2120
2121 Next_Actual (Actual);
2122 Next_Formal_With_Extras (Formal);
2123 end loop;
2124
2125 Rec_Nam := Make_Temporary (Loc, 'P');
2126
2127 if Has_Comp then
2128
2129 -- Generate:
2130 -- type Pnn is record
2131 -- Param1 : Ann1;
2132 -- ...
2133 -- ParamN : AnnN;
2134
2135 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are
2136 -- the original parameter names and Ann1 .. AnnN are the access to
2137 -- actual types.
2138
2139 Append_To (Decls,
2140 Make_Full_Type_Declaration (Loc,
2141 Defining_Identifier =>
2142 Rec_Nam,
2143 Type_Definition =>
2144 Make_Record_Definition (Loc,
2145 Component_List =>
2146 Make_Component_List (Loc, Comps))));
2147 else
2148 -- Generate:
2149 -- type Pnn is null record;
2150
2151 Append_To (Decls,
2152 Make_Full_Type_Declaration (Loc,
2153 Defining_Identifier =>
2154 Rec_Nam,
2155 Type_Definition =>
2156 Make_Record_Definition (Loc,
2157 Null_Present => True,
2158 Component_List => Empty)));
2159 end if;
2160
2161 return Rec_Nam;
2162 end Build_Parameter_Block;
2163
2164 --------------------------------------
2165 -- Build_Renamed_Formal_Declaration --
2166 --------------------------------------
2167
2168 function Build_Renamed_Formal_Declaration
2169 (New_F : Entity_Id;
2170 Formal : Entity_Id;
2171 Comp : Entity_Id;
2172 Renamed_Formal : Node_Id) return Node_Id
2173 is
2174 Loc : constant Source_Ptr := Sloc (New_F);
2175 Decl : Node_Id;
2176
2177 begin
2178 -- If the formal is a tagged incomplete type, it is already passed
2179 -- by reference, so it is sufficient to rename the pointer component
2180 -- that corresponds to the actual. Otherwise we need to dereference
2181 -- the pointer component to obtain the actual.
2182
2183 if Is_Incomplete_Type (Etype (Formal))
2184 and then Is_Tagged_Type (Etype (Formal))
2185 then
2186 Decl :=
2187 Make_Object_Renaming_Declaration (Loc,
2188 Defining_Identifier => New_F,
2189 Subtype_Mark => New_Occurrence_Of (Etype (Comp), Loc),
2190 Name => Renamed_Formal);
2191
2192 else
2193 Decl :=
2194 Make_Object_Renaming_Declaration (Loc,
2195 Defining_Identifier => New_F,
2196 Subtype_Mark => New_Occurrence_Of (Etype (Formal), Loc),
2197 Name =>
2198 Make_Explicit_Dereference (Loc, Renamed_Formal));
2199 end if;
2200
2201 return Decl;
2202 end Build_Renamed_Formal_Declaration;
2203
2204 --------------------------
2205 -- Build_Wrapper_Bodies --
2206 --------------------------
2207
2208 procedure Build_Wrapper_Bodies
2209 (Loc : Source_Ptr;
2210 Typ : Entity_Id;
2211 N : Node_Id)
2212 is
2213 Rec_Typ : Entity_Id;
2214
2215 function Build_Wrapper_Body
2216 (Loc : Source_Ptr;
2217 Subp_Id : Entity_Id;
2218 Obj_Typ : Entity_Id;
2219 Formals : List_Id) return Node_Id;
2220 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
2221 -- associated with a protected or task type. Subp_Id is the subprogram
2222 -- name which will be wrapped. Obj_Typ is the type of the new formal
2223 -- parameter which handles dispatching and object notation. Formals are
2224 -- the original formals of Subp_Id which will be explicitly replicated.
2225
2226 ------------------------
2227 -- Build_Wrapper_Body --
2228 ------------------------
2229
2230 function Build_Wrapper_Body
2231 (Loc : Source_Ptr;
2232 Subp_Id : Entity_Id;
2233 Obj_Typ : Entity_Id;
2234 Formals : List_Id) return Node_Id
2235 is
2236 Body_Spec : Node_Id;
2237
2238 begin
2239 Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals);
2240
2241 -- The subprogram is not overriding or is not a primitive declared
2242 -- between two views.
2243
2244 if No (Body_Spec) then
2245 return Empty;
2246 end if;
2247
2248 declare
2249 Actuals : List_Id := No_List;
2250 Conv_Id : Node_Id;
2251 First_Form : Node_Id;
2252 Formal : Node_Id;
2253 Nam : Node_Id;
2254
2255 begin
2256 -- Map formals to actuals. Use the list built for the wrapper
2257 -- spec, skipping the object notation parameter.
2258
2259 First_Form := First (Parameter_Specifications (Body_Spec));
2260
2261 Formal := First_Form;
2262 Next (Formal);
2263
2264 if Present (Formal) then
2265 Actuals := New_List;
2266 while Present (Formal) loop
2267 Append_To (Actuals,
2268 Make_Identifier (Loc,
2269 Chars => Chars (Defining_Identifier (Formal))));
2270 Next (Formal);
2271 end loop;
2272 end if;
2273
2274 -- Special processing for primitives declared between a private
2275 -- type and its completion: the wrapper needs a properly typed
2276 -- parameter if the wrapped operation has a controlling first
2277 -- parameter. Note that this might not be the case for a function
2278 -- with a controlling result.
2279
2280 if Is_Private_Primitive_Subprogram (Subp_Id) then
2281 if No (Actuals) then
2282 Actuals := New_List;
2283 end if;
2284
2285 if Is_Controlling_Formal (First_Formal (Subp_Id)) then
2286 Prepend_To (Actuals,
2287 Unchecked_Convert_To
2288 (Corresponding_Concurrent_Type (Obj_Typ),
2289 Make_Identifier (Loc, Name_uO)));
2290
2291 else
2292 Prepend_To (Actuals,
2293 Make_Identifier (Loc,
2294 Chars => Chars (Defining_Identifier (First_Form))));
2295 end if;
2296
2297 Nam := New_Occurrence_Of (Subp_Id, Loc);
2298 else
2299 -- An access-to-variable object parameter requires an explicit
2300 -- dereference in the unchecked conversion. This case occurs
2301 -- when a protected entry wrapper must override an interface
2302 -- level procedure with interface access as first parameter.
2303
2304 -- O.all.Subp_Id (Formal_1, ..., Formal_N)
2305
2306 if Nkind (Parameter_Type (First_Form)) =
2307 N_Access_Definition
2308 then
2309 Conv_Id :=
2310 Make_Explicit_Dereference (Loc,
2311 Prefix => Make_Identifier (Loc, Name_uO));
2312 else
2313 Conv_Id := Make_Identifier (Loc, Name_uO);
2314 end if;
2315
2316 Nam :=
2317 Make_Selected_Component (Loc,
2318 Prefix =>
2319 Unchecked_Convert_To
2320 (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id),
2321 Selector_Name => New_Occurrence_Of (Subp_Id, Loc));
2322 end if;
2323
2324 -- Create the subprogram body. For a function, the call to the
2325 -- actual subprogram has to be converted to the corresponding
2326 -- record if it is a controlling result.
2327
2328 if Ekind (Subp_Id) = E_Function then
2329 declare
2330 Res : Node_Id;
2331
2332 begin
2333 Res :=
2334 Make_Function_Call (Loc,
2335 Name => Nam,
2336 Parameter_Associations => Actuals);
2337
2338 if Has_Controlling_Result (Subp_Id) then
2339 Res :=
2340 Unchecked_Convert_To
2341 (Corresponding_Record_Type (Etype (Subp_Id)), Res);
2342 end if;
2343
2344 return
2345 Make_Subprogram_Body (Loc,
2346 Specification => Body_Spec,
2347 Declarations => Empty_List,
2348 Handled_Statement_Sequence =>
2349 Make_Handled_Sequence_Of_Statements (Loc,
2350 Statements => New_List (
2351 Make_Simple_Return_Statement (Loc, Res))));
2352 end;
2353
2354 else
2355 return
2356 Make_Subprogram_Body (Loc,
2357 Specification => Body_Spec,
2358 Declarations => Empty_List,
2359 Handled_Statement_Sequence =>
2360 Make_Handled_Sequence_Of_Statements (Loc,
2361 Statements => New_List (
2362 Make_Procedure_Call_Statement (Loc,
2363 Name => Nam,
2364 Parameter_Associations => Actuals))));
2365 end if;
2366 end;
2367 end Build_Wrapper_Body;
2368
2369 -- Start of processing for Build_Wrapper_Bodies
2370
2371 begin
2372 if Is_Concurrent_Type (Typ) then
2373 Rec_Typ := Corresponding_Record_Type (Typ);
2374 else
2375 Rec_Typ := Typ;
2376 end if;
2377
2378 -- Generate wrapper bodies for a concurrent type which implements an
2379 -- interface.
2380
2381 if Present (Interfaces (Rec_Typ)) then
2382 declare
2383 Insert_Nod : Node_Id;
2384 Prim : Entity_Id;
2385 Prim_Elmt : Elmt_Id;
2386 Prim_Decl : Node_Id;
2387 Subp : Entity_Id;
2388 Wrap_Body : Node_Id;
2389 Wrap_Id : Entity_Id;
2390
2391 begin
2392 Insert_Nod := N;
2393
2394 -- Examine all primitive operations of the corresponding record
2395 -- type, looking for wrapper specs. Generate bodies in order to
2396 -- complete them.
2397
2398 Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ));
2399 while Present (Prim_Elmt) loop
2400 Prim := Node (Prim_Elmt);
2401
2402 if (Ekind (Prim) = E_Function
2403 or else Ekind (Prim) = E_Procedure)
2404 and then Is_Primitive_Wrapper (Prim)
2405 then
2406 Subp := Wrapped_Entity (Prim);
2407 Prim_Decl := Parent (Parent (Prim));
2408
2409 Wrap_Body :=
2410 Build_Wrapper_Body (Loc,
2411 Subp_Id => Subp,
2412 Obj_Typ => Rec_Typ,
2413 Formals => Parameter_Specifications (Parent (Subp)));
2414 Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body));
2415
2416 Set_Corresponding_Spec (Wrap_Body, Prim);
2417 Set_Corresponding_Body (Prim_Decl, Wrap_Id);
2418
2419 Insert_After (Insert_Nod, Wrap_Body);
2420 Insert_Nod := Wrap_Body;
2421
2422 Analyze (Wrap_Body);
2423 end if;
2424
2425 Next_Elmt (Prim_Elmt);
2426 end loop;
2427 end;
2428 end if;
2429 end Build_Wrapper_Bodies;
2430
2431 ------------------------
2432 -- Build_Wrapper_Spec --
2433 ------------------------
2434
2435 function Build_Wrapper_Spec
2436 (Subp_Id : Entity_Id;
2437 Obj_Typ : Entity_Id;
2438 Formals : List_Id) return Node_Id
2439 is
2440 function Overriding_Possible
2441 (Iface_Op : Entity_Id;
2442 Wrapper : Entity_Id) return Boolean;
2443 -- Determine whether a primitive operation can be overridden by Wrapper.
2444 -- Iface_Op is the candidate primitive operation of an interface type,
2445 -- Wrapper is the generated entry wrapper.
2446
2447 function Replicate_Formals
2448 (Loc : Source_Ptr;
2449 Formals : List_Id) return List_Id;
2450 -- An explicit parameter replication is required due to the Is_Entry_
2451 -- Formal flag being set for all the formals of an entry. The explicit
2452 -- replication removes the flag that would otherwise cause a different
2453 -- path of analysis.
2454
2455 -------------------------
2456 -- Overriding_Possible --
2457 -------------------------
2458
2459 function Overriding_Possible
2460 (Iface_Op : Entity_Id;
2461 Wrapper : Entity_Id) return Boolean
2462 is
2463 Iface_Op_Spec : constant Node_Id := Parent (Iface_Op);
2464 Wrapper_Spec : constant Node_Id := Parent (Wrapper);
2465
2466 function Type_Conformant_Parameters
2467 (Iface_Op_Params : List_Id;
2468 Wrapper_Params : List_Id) return Boolean;
2469 -- Determine whether the parameters of the generated entry wrapper
2470 -- and those of a primitive operation are type conformant. During
2471 -- this check, the first parameter of the primitive operation is
2472 -- skipped if it is a controlling argument: protected functions
2473 -- may have a controlling result.
2474
2475 --------------------------------
2476 -- Type_Conformant_Parameters --
2477 --------------------------------
2478
2479 function Type_Conformant_Parameters
2480 (Iface_Op_Params : List_Id;
2481 Wrapper_Params : List_Id) return Boolean
2482 is
2483 Iface_Op_Param : Node_Id;
2484 Iface_Op_Typ : Entity_Id;
2485 Wrapper_Param : Node_Id;
2486 Wrapper_Typ : Entity_Id;
2487
2488 begin
2489 -- Skip the first (controlling) parameter of primitive operation
2490
2491 Iface_Op_Param := First (Iface_Op_Params);
2492
2493 if Present (First_Formal (Iface_Op))
2494 and then Is_Controlling_Formal (First_Formal (Iface_Op))
2495 then
2496 Iface_Op_Param := Next (Iface_Op_Param);
2497 end if;
2498
2499 Wrapper_Param := First (Wrapper_Params);
2500 while Present (Iface_Op_Param)
2501 and then Present (Wrapper_Param)
2502 loop
2503 Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param);
2504 Wrapper_Typ := Find_Parameter_Type (Wrapper_Param);
2505
2506 -- The two parameters must be mode conformant
2507
2508 if not Conforming_Types
2509 (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant)
2510 then
2511 return False;
2512 end if;
2513
2514 Next (Iface_Op_Param);
2515 Next (Wrapper_Param);
2516 end loop;
2517
2518 -- One of the lists is longer than the other
2519
2520 if Present (Iface_Op_Param) or else Present (Wrapper_Param) then
2521 return False;
2522 end if;
2523
2524 return True;
2525 end Type_Conformant_Parameters;
2526
2527 -- Start of processing for Overriding_Possible
2528
2529 begin
2530 if Chars (Iface_Op) /= Chars (Wrapper) then
2531 return False;
2532 end if;
2533
2534 -- If an inherited subprogram is implemented by a protected procedure
2535 -- or an entry, then the first parameter of the inherited subprogram
2536 -- must be of mode OUT or IN OUT, or access-to-variable parameter.
2537
2538 if Ekind (Iface_Op) = E_Procedure
2539 and then Present (Parameter_Specifications (Iface_Op_Spec))
2540 then
2541 declare
2542 Obj_Param : constant Node_Id :=
2543 First (Parameter_Specifications (Iface_Op_Spec));
2544 begin
2545 if not Out_Present (Obj_Param)
2546 and then Nkind (Parameter_Type (Obj_Param)) /=
2547 N_Access_Definition
2548 then
2549 return False;
2550 end if;
2551 end;
2552 end if;
2553
2554 return
2555 Type_Conformant_Parameters
2556 (Parameter_Specifications (Iface_Op_Spec),
2557 Parameter_Specifications (Wrapper_Spec));
2558 end Overriding_Possible;
2559
2560 -----------------------
2561 -- Replicate_Formals --
2562 -----------------------
2563
2564 function Replicate_Formals
2565 (Loc : Source_Ptr;
2566 Formals : List_Id) return List_Id
2567 is
2568 New_Formals : constant List_Id := New_List;
2569 Formal : Node_Id;
2570 Param_Type : Node_Id;
2571
2572 begin
2573 Formal := First (Formals);
2574
2575 -- Skip the object parameter when dealing with primitives declared
2576 -- between two views.
2577
2578 if Is_Private_Primitive_Subprogram (Subp_Id)
2579 and then not Has_Controlling_Result (Subp_Id)
2580 then
2581 Formal := Next (Formal);
2582 end if;
2583
2584 while Present (Formal) loop
2585
2586 -- Create an explicit copy of the entry parameter
2587
2588 -- When creating the wrapper subprogram for a primitive operation
2589 -- of a protected interface we must construct an equivalent
2590 -- signature to that of the overriding operation. For regular
2591 -- parameters we can just use the type of the formal, but for
2592 -- access to subprogram parameters we need to reanalyze the
2593 -- parameter type to create local entities for the signature of
2594 -- the subprogram type. Using the entities of the overriding
2595 -- subprogram will result in out-of-scope errors in the back-end.
2596
2597 if Nkind (Parameter_Type (Formal)) = N_Access_Definition then
2598 Param_Type := Copy_Separate_Tree (Parameter_Type (Formal));
2599 else
2600 Param_Type :=
2601 New_Occurrence_Of (Etype (Parameter_Type (Formal)), Loc);
2602 end if;
2603
2604 Append_To (New_Formals,
2605 Make_Parameter_Specification (Loc,
2606 Defining_Identifier =>
2607 Make_Defining_Identifier (Loc,
2608 Chars => Chars (Defining_Identifier (Formal))),
2609 In_Present => In_Present (Formal),
2610 Out_Present => Out_Present (Formal),
2611 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
2612 Parameter_Type => Param_Type));
2613
2614 Next (Formal);
2615 end loop;
2616
2617 return New_Formals;
2618 end Replicate_Formals;
2619
2620 -- Local variables
2621
2622 Loc : constant Source_Ptr := Sloc (Subp_Id);
2623 First_Param : Node_Id := Empty;
2624 Iface : Entity_Id;
2625 Iface_Elmt : Elmt_Id;
2626 Iface_Op : Entity_Id;
2627 Iface_Op_Elmt : Elmt_Id;
2628 Overridden_Subp : Entity_Id;
2629
2630 -- Start of processing for Build_Wrapper_Spec
2631
2632 begin
2633 -- No point in building wrappers for untagged concurrent types
2634
2635 pragma Assert (Is_Tagged_Type (Obj_Typ));
2636
2637 -- Check if this subprogram has a profile that matches some interface
2638 -- primitive.
2639
2640 Check_Synchronized_Overriding (Subp_Id, Overridden_Subp);
2641
2642 if Present (Overridden_Subp) then
2643 First_Param :=
2644 First (Parameter_Specifications (Parent (Overridden_Subp)));
2645
2646 -- An entry or a protected procedure can override a routine where the
2647 -- controlling formal is either IN OUT, OUT or is of access-to-variable
2648 -- type. Since the wrapper must have the exact same signature as that of
2649 -- the overridden subprogram, we try to find the overriding candidate
2650 -- and use its controlling formal.
2651
2652 -- Check every implemented interface
2653
2654 elsif Present (Interfaces (Obj_Typ)) then
2655 Iface_Elmt := First_Elmt (Interfaces (Obj_Typ));
2656 Search : while Present (Iface_Elmt) loop
2657 Iface := Node (Iface_Elmt);
2658
2659 -- Check every interface primitive
2660
2661 if Present (Primitive_Operations (Iface)) then
2662 Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
2663 while Present (Iface_Op_Elmt) loop
2664 Iface_Op := Node (Iface_Op_Elmt);
2665
2666 -- Ignore predefined primitives
2667
2668 if not Is_Predefined_Dispatching_Operation (Iface_Op) then
2669 Iface_Op := Ultimate_Alias (Iface_Op);
2670
2671 -- The current primitive operation can be overridden by
2672 -- the generated entry wrapper.
2673
2674 if Overriding_Possible (Iface_Op, Subp_Id) then
2675 First_Param :=
2676 First (Parameter_Specifications (Parent (Iface_Op)));
2677
2678 exit Search;
2679 end if;
2680 end if;
2681
2682 Next_Elmt (Iface_Op_Elmt);
2683 end loop;
2684 end if;
2685
2686 Next_Elmt (Iface_Elmt);
2687 end loop Search;
2688 end if;
2689
2690 -- Do not generate the wrapper if no interface primitive is covered by
2691 -- the subprogram and it is not a primitive declared between two views
2692 -- (see Process_Full_View).
2693
2694 if No (First_Param)
2695 and then not Is_Private_Primitive_Subprogram (Subp_Id)
2696 then
2697 return Empty;
2698 end if;
2699
2700 declare
2701 Wrapper_Id : constant Entity_Id :=
2702 Make_Defining_Identifier (Loc, Chars (Subp_Id));
2703 New_Formals : List_Id;
2704 Obj_Param : Node_Id;
2705 Obj_Param_Typ : Entity_Id;
2706
2707 begin
2708 -- Minimum decoration is needed to catch the entity in
2709 -- Sem_Ch6.Override_Dispatching_Operation.
2710
2711 if Ekind (Subp_Id) = E_Function then
2712 Set_Ekind (Wrapper_Id, E_Function);
2713 else
2714 Set_Ekind (Wrapper_Id, E_Procedure);
2715 end if;
2716
2717 Set_Is_Primitive_Wrapper (Wrapper_Id);
2718 Set_Wrapped_Entity (Wrapper_Id, Subp_Id);
2719 Set_Is_Private_Primitive (Wrapper_Id,
2720 Is_Private_Primitive_Subprogram (Subp_Id));
2721
2722 -- Process the formals
2723
2724 New_Formals := Replicate_Formals (Loc, Formals);
2725
2726 -- A function with a controlling result and no first controlling
2727 -- formal needs no additional parameter.
2728
2729 if Has_Controlling_Result (Subp_Id)
2730 and then
2731 (No (First_Formal (Subp_Id))
2732 or else not Is_Controlling_Formal (First_Formal (Subp_Id)))
2733 then
2734 null;
2735
2736 -- Routine Subp_Id has been found to override an interface primitive.
2737 -- If the interface operation has an access parameter, create a copy
2738 -- of it, with the same null exclusion indicator if present.
2739
2740 elsif Present (First_Param) then
2741 if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
2742 Obj_Param_Typ :=
2743 Make_Access_Definition (Loc,
2744 Subtype_Mark =>
2745 New_Occurrence_Of (Obj_Typ, Loc),
2746 Null_Exclusion_Present =>
2747 Null_Exclusion_Present (Parameter_Type (First_Param)),
2748 Constant_Present =>
2749 Constant_Present (Parameter_Type (First_Param)));
2750 else
2751 Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc);
2752 end if;
2753
2754 Obj_Param :=
2755 Make_Parameter_Specification (Loc,
2756 Defining_Identifier =>
2757 Make_Defining_Identifier (Loc,
2758 Chars => Name_uO),
2759 In_Present => In_Present (First_Param),
2760 Out_Present => Out_Present (First_Param),
2761 Parameter_Type => Obj_Param_Typ);
2762
2763 Prepend_To (New_Formals, Obj_Param);
2764
2765 -- If we are dealing with a primitive declared between two views,
2766 -- implemented by a synchronized operation, we need to create
2767 -- a default parameter. The mode of the parameter must match that
2768 -- of the primitive operation.
2769
2770 else
2771 pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
2772
2773 Obj_Param :=
2774 Make_Parameter_Specification (Loc,
2775 Defining_Identifier =>
2776 Make_Defining_Identifier (Loc, Name_uO),
2777 In_Present =>
2778 In_Present (Parent (First_Entity (Subp_Id))),
2779 Out_Present => Ekind (Subp_Id) /= E_Function,
2780 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
2781
2782 Prepend_To (New_Formals, Obj_Param);
2783 end if;
2784
2785 -- Build the final spec. If it is a function with a controlling
2786 -- result, it is a primitive operation of the corresponding
2787 -- record type, so mark the spec accordingly.
2788
2789 if Ekind (Subp_Id) = E_Function then
2790 declare
2791 Res_Def : Node_Id;
2792
2793 begin
2794 if Has_Controlling_Result (Subp_Id) then
2795 Res_Def :=
2796 New_Occurrence_Of
2797 (Corresponding_Record_Type (Etype (Subp_Id)), Loc);
2798 else
2799 Res_Def := New_Copy (Result_Definition (Parent (Subp_Id)));
2800 end if;
2801
2802 return
2803 Make_Function_Specification (Loc,
2804 Defining_Unit_Name => Wrapper_Id,
2805 Parameter_Specifications => New_Formals,
2806 Result_Definition => Res_Def);
2807 end;
2808 else
2809 return
2810 Make_Procedure_Specification (Loc,
2811 Defining_Unit_Name => Wrapper_Id,
2812 Parameter_Specifications => New_Formals);
2813 end if;
2814 end;
2815 end Build_Wrapper_Spec;
2816
2817 -------------------------
2818 -- Build_Wrapper_Specs --
2819 -------------------------
2820
2821 procedure Build_Wrapper_Specs
2822 (Loc : Source_Ptr;
2823 Typ : Entity_Id;
2824 N : in out Node_Id)
2825 is
2826 Def : Node_Id;
2827 Rec_Typ : Entity_Id;
2828 procedure Scan_Declarations (L : List_Id);
2829 -- Common processing for visible and private declarations
2830 -- of a protected type.
2831
2832 procedure Scan_Declarations (L : List_Id) is
2833 Decl : Node_Id;
2834 Wrap_Decl : Node_Id;
2835 Wrap_Spec : Node_Id;
2836
2837 begin
2838 if No (L) then
2839 return;
2840 end if;
2841
2842 Decl := First (L);
2843 while Present (Decl) loop
2844 Wrap_Spec := Empty;
2845
2846 if Nkind (Decl) = N_Entry_Declaration
2847 and then Ekind (Defining_Identifier (Decl)) = E_Entry
2848 then
2849 Wrap_Spec :=
2850 Build_Wrapper_Spec
2851 (Subp_Id => Defining_Identifier (Decl),
2852 Obj_Typ => Rec_Typ,
2853 Formals => Parameter_Specifications (Decl));
2854
2855 elsif Nkind (Decl) = N_Subprogram_Declaration then
2856 Wrap_Spec :=
2857 Build_Wrapper_Spec
2858 (Subp_Id => Defining_Unit_Name (Specification (Decl)),
2859 Obj_Typ => Rec_Typ,
2860 Formals =>
2861 Parameter_Specifications (Specification (Decl)));
2862 end if;
2863
2864 if Present (Wrap_Spec) then
2865 Wrap_Decl :=
2866 Make_Subprogram_Declaration (Loc,
2867 Specification => Wrap_Spec);
2868
2869 Insert_After (N, Wrap_Decl);
2870 N := Wrap_Decl;
2871
2872 Analyze (Wrap_Decl);
2873 end if;
2874
2875 Next (Decl);
2876 end loop;
2877 end Scan_Declarations;
2878
2879 -- start of processing for Build_Wrapper_Specs
2880
2881 begin
2882 if Is_Protected_Type (Typ) then
2883 Def := Protected_Definition (Parent (Typ));
2884 else pragma Assert (Is_Task_Type (Typ));
2885 Def := Task_Definition (Parent (Typ));
2886 end if;
2887
2888 Rec_Typ := Corresponding_Record_Type (Typ);
2889
2890 -- Generate wrapper specs for a concurrent type which implements an
2891 -- interface. Operations in both the visible and private parts may
2892 -- implement progenitor operations.
2893
2894 if Present (Interfaces (Rec_Typ)) and then Present (Def) then
2895 Scan_Declarations (Visible_Declarations (Def));
2896 Scan_Declarations (Private_Declarations (Def));
2897 end if;
2898 end Build_Wrapper_Specs;
2899
2900 ---------------------------
2901 -- Build_Find_Body_Index --
2902 ---------------------------
2903
2904 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is
2905 Loc : constant Source_Ptr := Sloc (Typ);
2906 Ent : Entity_Id;
2907 E_Typ : Entity_Id;
2908 Has_F : Boolean := False;
2909 Index : Nat;
2910 If_St : Node_Id := Empty;
2911 Lo : Node_Id;
2912 Hi : Node_Id;
2913 Decls : List_Id := New_List;
2914 Ret : Node_Id;
2915 Spec : Node_Id;
2916 Siz : Node_Id := Empty;
2917
2918 procedure Add_If_Clause (Expr : Node_Id);
2919 -- Add test for range of current entry
2920
2921 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
2922 -- If a bound of an entry is given by a discriminant, retrieve the
2923 -- actual value of the discriminant from the enclosing object.
2924
2925 -------------------
2926 -- Add_If_Clause --
2927 -------------------
2928
2929 procedure Add_If_Clause (Expr : Node_Id) is
2930 Cond : Node_Id;
2931 Stats : constant List_Id :=
2932 New_List (
2933 Make_Simple_Return_Statement (Loc,
2934 Expression => Make_Integer_Literal (Loc, Index + 1)));
2935
2936 begin
2937 -- Index for current entry body
2938
2939 Index := Index + 1;
2940
2941 -- Compute total length of entry queues so far
2942
2943 if No (Siz) then
2944 Siz := Expr;
2945 else
2946 Siz :=
2947 Make_Op_Add (Loc,
2948 Left_Opnd => Siz,
2949 Right_Opnd => Expr);
2950 end if;
2951
2952 Cond :=
2953 Make_Op_Le (Loc,
2954 Left_Opnd => Make_Identifier (Loc, Name_uE),
2955 Right_Opnd => Siz);
2956
2957 -- Map entry queue indexes in the range of the current family
2958 -- into the current index, that designates the entry body.
2959
2960 if No (If_St) then
2961 If_St :=
2962 Make_Implicit_If_Statement (Typ,
2963 Condition => Cond,
2964 Then_Statements => Stats,
2965 Elsif_Parts => New_List);
2966 Ret := If_St;
2967
2968 else
2969 Append_To (Elsif_Parts (If_St),
2970 Make_Elsif_Part (Loc,
2971 Condition => Cond,
2972 Then_Statements => Stats));
2973 end if;
2974 end Add_If_Clause;
2975
2976 ------------------------------
2977 -- Convert_Discriminant_Ref --
2978 ------------------------------
2979
2980 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
2981 B : Node_Id;
2982
2983 begin
2984 if Is_Entity_Name (Bound)
2985 and then Ekind (Entity (Bound)) = E_Discriminant
2986 then
2987 B :=
2988 Make_Selected_Component (Loc,
2989 Prefix =>
2990 Unchecked_Convert_To (Corresponding_Record_Type (Typ),
2991 Make_Explicit_Dereference (Loc,
2992 Make_Identifier (Loc, Name_uObject))),
2993 Selector_Name => Make_Identifier (Loc, Chars (Bound)));
2994 Set_Etype (B, Etype (Entity (Bound)));
2995 else
2996 B := New_Copy_Tree (Bound);
2997 end if;
2998
2999 return B;
3000 end Convert_Discriminant_Ref;
3001
3002 -- Start of processing for Build_Find_Body_Index
3003
3004 begin
3005 Spec := Build_Find_Body_Index_Spec (Typ);
3006
3007 Ent := First_Entity (Typ);
3008 while Present (Ent) loop
3009 if Ekind (Ent) = E_Entry_Family then
3010 Has_F := True;
3011 exit;
3012 end if;
3013
3014 Next_Entity (Ent);
3015 end loop;
3016
3017 if not Has_F then
3018
3019 -- If the protected type has no entry families, there is a one-one
3020 -- correspondence between entry queue and entry body.
3021
3022 Ret :=
3023 Make_Simple_Return_Statement (Loc,
3024 Expression => Make_Identifier (Loc, Name_uE));
3025
3026 else
3027 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate
3028 -- the following:
3029
3030 -- if E <= l1 then return 1;
3031 -- elsif E <= l1 + l2 then return 2;
3032 -- ...
3033
3034 Index := 0;
3035 Siz := Empty;
3036 Ent := First_Entity (Typ);
3037
3038 Add_Object_Pointer (Loc, Typ, Decls);
3039
3040 while Present (Ent) loop
3041 if Ekind (Ent) = E_Entry then
3042 Add_If_Clause (Make_Integer_Literal (Loc, 1));
3043
3044 elsif Ekind (Ent) = E_Entry_Family then
3045 E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
3046 Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
3047 Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ));
3048 Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False));
3049 end if;
3050
3051 Next_Entity (Ent);
3052 end loop;
3053
3054 if Index = 1 then
3055 Decls := New_List;
3056 Ret :=
3057 Make_Simple_Return_Statement (Loc,
3058 Expression => Make_Integer_Literal (Loc, 1));
3059
3060 elsif Nkind (Ret) = N_If_Statement then
3061
3062 -- Ranges are in increasing order, so last one doesn't need guard
3063
3064 declare
3065 Nod : constant Node_Id := Last (Elsif_Parts (Ret));
3066 begin
3067 Remove (Nod);
3068 Set_Else_Statements (Ret, Then_Statements (Nod));
3069 end;
3070 end if;
3071 end if;
3072
3073 return
3074 Make_Subprogram_Body (Loc,
3075 Specification => Spec,
3076 Declarations => Decls,
3077 Handled_Statement_Sequence =>
3078 Make_Handled_Sequence_Of_Statements (Loc,
3079 Statements => New_List (Ret)));
3080 end Build_Find_Body_Index;
3081
3082 --------------------------------
3083 -- Build_Find_Body_Index_Spec --
3084 --------------------------------
3085
3086 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
3087 Loc : constant Source_Ptr := Sloc (Typ);
3088 Id : constant Entity_Id :=
3089 Make_Defining_Identifier (Loc,
3090 Chars => New_External_Name (Chars (Typ), 'F'));
3091 Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
3092 Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
3093
3094 begin
3095 return
3096 Make_Function_Specification (Loc,
3097 Defining_Unit_Name => Id,
3098 Parameter_Specifications => New_List (
3099 Make_Parameter_Specification (Loc,
3100 Defining_Identifier => Parm1,
3101 Parameter_Type =>
3102 New_Occurrence_Of (RTE (RE_Address), Loc)),
3103
3104 Make_Parameter_Specification (Loc,
3105 Defining_Identifier => Parm2,
3106 Parameter_Type =>
3107 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))),
3108
3109 Result_Definition => New_Occurrence_Of (
3110 RTE (RE_Protected_Entry_Index), Loc));
3111 end Build_Find_Body_Index_Spec;
3112
3113 -----------------------------------------------
3114 -- Build_Lock_Free_Protected_Subprogram_Body --
3115 -----------------------------------------------
3116
3117 function Build_Lock_Free_Protected_Subprogram_Body
3118 (N : Node_Id;
3119 Prot_Typ : Node_Id;
3120 Unprot_Spec : Node_Id) return Node_Id
3121 is
3122 Actuals : constant List_Id := New_List;
3123 Loc : constant Source_Ptr := Sloc (N);
3124 Spec : constant Node_Id := Specification (N);
3125 Unprot_Id : constant Entity_Id := Defining_Unit_Name (Unprot_Spec);
3126 Formal : Node_Id;
3127 Prot_Spec : Node_Id;
3128 Stmt : Node_Id;
3129
3130 begin
3131 -- Create the protected version of the body
3132
3133 Prot_Spec :=
3134 Build_Protected_Sub_Specification (N, Prot_Typ, Protected_Mode);
3135
3136 -- Build the actual parameters which appear in the call to the
3137 -- unprotected version of the body.
3138
3139 Formal := First (Parameter_Specifications (Prot_Spec));
3140 while Present (Formal) loop
3141 Append_To (Actuals,
3142 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
3143
3144 Next (Formal);
3145 end loop;
3146
3147 -- Function case, generate:
3148 -- return <Unprot_Func_Call>;
3149
3150 if Nkind (Spec) = N_Function_Specification then
3151 Stmt :=
3152 Make_Simple_Return_Statement (Loc,
3153 Expression =>
3154 Make_Function_Call (Loc,
3155 Name =>
3156 Make_Identifier (Loc, Chars (Unprot_Id)),
3157 Parameter_Associations => Actuals));
3158
3159 -- Procedure case, call the unprotected version
3160
3161 else
3162 Stmt :=
3163 Make_Procedure_Call_Statement (Loc,
3164 Name =>
3165 Make_Identifier (Loc, Chars (Unprot_Id)),
3166 Parameter_Associations => Actuals);
3167 end if;
3168
3169 return
3170 Make_Subprogram_Body (Loc,
3171 Declarations => Empty_List,
3172 Specification => Prot_Spec,
3173 Handled_Statement_Sequence =>
3174 Make_Handled_Sequence_Of_Statements (Loc,
3175 Statements => New_List (Stmt)));
3176 end Build_Lock_Free_Protected_Subprogram_Body;
3177
3178 -------------------------------------------------
3179 -- Build_Lock_Free_Unprotected_Subprogram_Body --
3180 -------------------------------------------------
3181
3182 -- Procedures which meet the lock-free implementation requirements and
3183 -- reference a unique scalar component Comp are expanded in the following
3184 -- manner:
3185
3186 -- procedure P (...) is
3187 -- Expected_Comp : constant Comp_Type :=
3188 -- Comp_Type
3189 -- (System.Atomic_Primitives.Lock_Free_Read_N
3190 -- (_Object.Comp'Address));
3191 -- begin
3192 -- loop
3193 -- declare
3194 -- <original declarations before the object renaming declaration
3195 -- of Comp>
3196 --
3197 -- Desired_Comp : Comp_Type := Expected_Comp;
3198 -- Comp : Comp_Type renames Desired_Comp;
3199 --
3200 -- <original delarations after the object renaming declaration
3201 -- of Comp>
3202 --
3203 -- begin
3204 -- <original statements>
3205 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3206 -- (_Object.Comp'Address,
3207 -- Interfaces.Unsigned_N (Expected_Comp),
3208 -- Interfaces.Unsigned_N (Desired_Comp));
3209 -- end;
3210 -- end loop;
3211 -- end P;
3212
3213 -- Each return and raise statement of P is transformed into an atomic
3214 -- status check:
3215
3216 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3217 -- (_Object.Comp'Address,
3218 -- Interfaces.Unsigned_N (Expected_Comp),
3219 -- Interfaces.Unsigned_N (Desired_Comp));
3220 -- then
3221 -- <original statement>
3222 -- else
3223 -- goto L0;
3224 -- end if;
3225
3226 -- Functions which meet the lock-free implementation requirements and
3227 -- reference a unique scalar component Comp are expanded in the following
3228 -- manner:
3229
3230 -- function F (...) return ... is
3231 -- <original declarations before the object renaming declaration
3232 -- of Comp>
3233 --
3234 -- Expected_Comp : constant Comp_Type :=
3235 -- Comp_Type
3236 -- (System.Atomic_Primitives.Lock_Free_Read_N
3237 -- (_Object.Comp'Address));
3238 -- Comp : Comp_Type renames Expected_Comp;
3239 --
3240 -- <original delarations after the object renaming declaration of
3241 -- Comp>
3242 --
3243 -- begin
3244 -- <original statements>
3245 -- end F;
3246
3247 function Build_Lock_Free_Unprotected_Subprogram_Body
3248 (N : Node_Id;
3249 Prot_Typ : Node_Id) return Node_Id
3250 is
3251 function Referenced_Component (N : Node_Id) return Entity_Id;
3252 -- Subprograms which meet the lock-free implementation criteria are
3253 -- allowed to reference only one unique component. Return the prival
3254 -- of the said component.
3255
3256 --------------------------
3257 -- Referenced_Component --
3258 --------------------------
3259
3260 function Referenced_Component (N : Node_Id) return Entity_Id is
3261 Comp : Entity_Id;
3262 Decl : Node_Id;
3263 Source_Comp : Entity_Id := Empty;
3264
3265 begin
3266 -- Find the unique source component which N references in its
3267 -- statements.
3268
3269 for Index in 1 .. Lock_Free_Subprogram_Table.Last loop
3270 declare
3271 Element : Lock_Free_Subprogram renames
3272 Lock_Free_Subprogram_Table.Table (Index);
3273 begin
3274 if Element.Sub_Body = N then
3275 Source_Comp := Element.Comp_Id;
3276 exit;
3277 end if;
3278 end;
3279 end loop;
3280
3281 if No (Source_Comp) then
3282 return Empty;
3283 end if;
3284
3285 -- Find the prival which corresponds to the source component within
3286 -- the declarations of N.
3287
3288 Decl := First (Declarations (N));
3289 while Present (Decl) loop
3290
3291 -- Privals appear as object renamings
3292
3293 if Nkind (Decl) = N_Object_Renaming_Declaration then
3294 Comp := Defining_Identifier (Decl);
3295
3296 if Present (Prival_Link (Comp))
3297 and then Prival_Link (Comp) = Source_Comp
3298 then
3299 return Comp;
3300 end if;
3301 end if;
3302
3303 Next (Decl);
3304 end loop;
3305
3306 return Empty;
3307 end Referenced_Component;
3308
3309 -- Local variables
3310
3311 Comp : constant Entity_Id := Referenced_Component (N);
3312 Loc : constant Source_Ptr := Sloc (N);
3313 Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N);
3314 Decls : List_Id := Declarations (N);
3315
3316 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
3317
3318 begin
3319 -- Add renamings for the protection object, discriminals, privals, and
3320 -- the entry index constant for use by debugger.
3321
3322 Debug_Private_Data_Declarations (Decls);
3323
3324 -- Perform the lock-free expansion when the subprogram references a
3325 -- protected component.
3326
3327 if Present (Comp) then
3328 Protected_Component_Ref : declare
3329 Comp_Decl : constant Node_Id := Parent (Comp);
3330 Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl);
3331 Comp_Type : constant Entity_Id := Etype (Comp);
3332
3333 Is_Procedure : constant Boolean :=
3334 Ekind (Corresponding_Spec (N)) = E_Procedure;
3335 -- Indicates if N is a protected procedure body
3336
3337 Block_Decls : List_Id;
3338 Try_Write : Entity_Id;
3339 Desired_Comp : Entity_Id;
3340 Decl : Node_Id;
3341 Label : Node_Id;
3342 Label_Id : Entity_Id := Empty;
3343 Read : Entity_Id;
3344 Expected_Comp : Entity_Id;
3345 Stmt : Node_Id;
3346 Stmts : List_Id :=
3347 New_Copy_List (Statements (Hand_Stmt_Seq));
3348 Typ_Size : Int;
3349 Unsigned : Entity_Id;
3350
3351 function Process_Node (N : Node_Id) return Traverse_Result;
3352 -- Transform a single node if it is a return statement, a raise
3353 -- statement or a reference to Comp.
3354
3355 procedure Process_Stmts (Stmts : List_Id);
3356 -- Given a statement sequence Stmts, wrap any return or raise
3357 -- statements in the following manner:
3358 --
3359 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3360 -- (_Object.Comp'Address,
3361 -- Interfaces.Unsigned_N (Expected_Comp),
3362 -- Interfaces.Unsigned_N (Desired_Comp))
3363 -- then
3364 -- <Stmt>;
3365 -- else
3366 -- goto L0;
3367 -- end if;
3368
3369 ------------------
3370 -- Process_Node --
3371 ------------------
3372
3373 function Process_Node (N : Node_Id) return Traverse_Result is
3374
3375 procedure Wrap_Statement (Stmt : Node_Id);
3376 -- Wrap an arbitrary statement inside an if statement where the
3377 -- condition does an atomic check on the state of the object.
3378
3379 --------------------
3380 -- Wrap_Statement --
3381 --------------------
3382
3383 procedure Wrap_Statement (Stmt : Node_Id) is
3384 begin
3385 -- The first time through, create the declaration of a label
3386 -- which is used to skip the remainder of source statements
3387 -- if the state of the object has changed.
3388
3389 if No (Label_Id) then
3390 Label_Id :=
3391 Make_Identifier (Loc, New_External_Name ('L', 0));
3392 Set_Entity (Label_Id,
3393 Make_Defining_Identifier (Loc, Chars (Label_Id)));
3394 end if;
3395
3396 -- Generate:
3397 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N
3398 -- (_Object.Comp'Address,
3399 -- Interfaces.Unsigned_N (Expected_Comp),
3400 -- Interfaces.Unsigned_N (Desired_Comp))
3401 -- then
3402 -- <Stmt>;
3403 -- else
3404 -- goto L0;
3405 -- end if;
3406
3407 Rewrite (Stmt,
3408 Make_Implicit_If_Statement (N,
3409 Condition =>
3410 Make_Function_Call (Loc,
3411 Name =>
3412 New_Occurrence_Of (Try_Write, Loc),
3413 Parameter_Associations => New_List (
3414 Make_Attribute_Reference (Loc,
3415 Prefix => Relocate_Node (Comp_Sel_Nam),
3416 Attribute_Name => Name_Address),
3417
3418 Unchecked_Convert_To (Unsigned,
3419 New_Occurrence_Of (Expected_Comp, Loc)),
3420
3421 Unchecked_Convert_To (Unsigned,
3422 New_Occurrence_Of (Desired_Comp, Loc)))),
3423
3424 Then_Statements => New_List (Relocate_Node (Stmt)),
3425
3426 Else_Statements => New_List (
3427 Make_Goto_Statement (Loc,
3428 Name =>
3429 New_Occurrence_Of (Entity (Label_Id), Loc)))));
3430 end Wrap_Statement;
3431
3432 -- Start of processing for Process_Node
3433
3434 begin
3435 -- Wrap each return and raise statement that appear inside a
3436 -- procedure. Skip the last return statement which is added by
3437 -- default since it is transformed into an exit statement.
3438
3439 if Is_Procedure
3440 and then ((Nkind (N) = N_Simple_Return_Statement
3441 and then N /= Last (Stmts))
3442 or else Nkind (N) = N_Extended_Return_Statement
3443 or else (Nkind_In (N, N_Raise_Constraint_Error,
3444 N_Raise_Program_Error,
3445 N_Raise_Statement,
3446 N_Raise_Storage_Error)
3447 and then Comes_From_Source (N)))
3448 then
3449 Wrap_Statement (N);
3450 return Skip;
3451 end if;
3452
3453 -- Force reanalysis
3454
3455 Set_Analyzed (N, False);
3456
3457 return OK;
3458 end Process_Node;
3459
3460 procedure Process_Nodes is new Traverse_Proc (Process_Node);
3461
3462 -------------------
3463 -- Process_Stmts --
3464 -------------------
3465
3466 procedure Process_Stmts (Stmts : List_Id) is
3467 Stmt : Node_Id;
3468 begin
3469 Stmt := First (Stmts);
3470 while Present (Stmt) loop
3471 Process_Nodes (Stmt);
3472 Next (Stmt);
3473 end loop;
3474 end Process_Stmts;
3475
3476 -- Start of processing for Protected_Component_Ref
3477
3478 begin
3479 -- Get the type size
3480
3481 if Known_Static_Esize (Comp_Type) then
3482 Typ_Size := UI_To_Int (Esize (Comp_Type));
3483
3484 -- If the Esize (Object_Size) is unknown at compile time, look at
3485 -- the RM_Size (Value_Size) since it may have been set by an
3486 -- explicit representation clause.
3487
3488 elsif Known_Static_RM_Size (Comp_Type) then
3489 Typ_Size := UI_To_Int (RM_Size (Comp_Type));
3490
3491 -- Should not happen since this has already been checked in
3492 -- Allows_Lock_Free_Implementation (see Sem_Ch9).
3493
3494 else
3495 raise Program_Error;
3496 end if;
3497
3498 -- Retrieve all relevant atomic routines and types
3499
3500 case Typ_Size is
3501 when 8 =>
3502 Try_Write := RTE (RE_Lock_Free_Try_Write_8);
3503 Read := RTE (RE_Lock_Free_Read_8);
3504 Unsigned := RTE (RE_Uint8);
3505
3506 when 16 =>
3507 Try_Write := RTE (RE_Lock_Free_Try_Write_16);
3508 Read := RTE (RE_Lock_Free_Read_16);
3509 Unsigned := RTE (RE_Uint16);
3510
3511 when 32 =>
3512 Try_Write := RTE (RE_Lock_Free_Try_Write_32);
3513 Read := RTE (RE_Lock_Free_Read_32);
3514 Unsigned := RTE (RE_Uint32);
3515
3516 when 64 =>
3517 Try_Write := RTE (RE_Lock_Free_Try_Write_64);
3518 Read := RTE (RE_Lock_Free_Read_64);
3519 Unsigned := RTE (RE_Uint64);
3520
3521 when others =>
3522 raise Program_Error;
3523 end case;
3524
3525 -- Generate:
3526 -- Expected_Comp : constant Comp_Type :=
3527 -- Comp_Type
3528 -- (System.Atomic_Primitives.Lock_Free_Read_N
3529 -- (_Object.Comp'Address));
3530
3531 Expected_Comp :=
3532 Make_Defining_Identifier (Loc,
3533 New_External_Name (Chars (Comp), Suffix => "_saved"));
3534
3535 Decl :=
3536 Make_Object_Declaration (Loc,
3537 Defining_Identifier => Expected_Comp,
3538 Object_Definition => New_Occurrence_Of (Comp_Type, Loc),
3539 Constant_Present => True,
3540 Expression =>
3541 Unchecked_Convert_To (Comp_Type,
3542 Make_Function_Call (Loc,
3543 Name => New_Occurrence_Of (Read, Loc),
3544 Parameter_Associations => New_List (
3545 Make_Attribute_Reference (Loc,
3546 Prefix => Relocate_Node (Comp_Sel_Nam),
3547 Attribute_Name => Name_Address)))));
3548
3549 -- Protected procedures
3550
3551 if Is_Procedure then
3552 -- Move the original declarations inside the generated block
3553
3554 Block_Decls := Decls;
3555
3556 -- Reset the declarations list of the protected procedure to
3557 -- contain only Decl.
3558
3559 Decls := New_List (Decl);
3560
3561 -- Generate:
3562 -- Desired_Comp : Comp_Type := Expected_Comp;
3563
3564 Desired_Comp :=
3565 Make_Defining_Identifier (Loc,
3566 New_External_Name (Chars (Comp), Suffix => "_current"));
3567
3568 -- Insert the declarations of Expected_Comp and Desired_Comp in
3569 -- the block declarations right before the renaming of the
3570 -- protected component.
3571
3572 Insert_Before (Comp_Decl,
3573 Make_Object_Declaration (Loc,
3574 Defining_Identifier => Desired_Comp,
3575 Object_Definition => New_Occurrence_Of (Comp_Type, Loc),
3576 Expression =>
3577 New_Occurrence_Of (Expected_Comp, Loc)));
3578
3579 -- Protected function
3580
3581 else
3582 Desired_Comp := Expected_Comp;
3583
3584 -- Insert the declaration of Expected_Comp in the function
3585 -- declarations right before the renaming of the protected
3586 -- component.
3587
3588 Insert_Before (Comp_Decl, Decl);
3589 end if;
3590
3591 -- Rewrite the protected component renaming declaration to be a
3592 -- renaming of Desired_Comp.
3593
3594 -- Generate:
3595 -- Comp : Comp_Type renames Desired_Comp;
3596
3597 Rewrite (Comp_Decl,
3598 Make_Object_Renaming_Declaration (Loc,
3599 Defining_Identifier =>
3600 Defining_Identifier (Comp_Decl),
3601 Subtype_Mark =>
3602 New_Occurrence_Of (Comp_Type, Loc),
3603 Name =>
3604 New_Occurrence_Of (Desired_Comp, Loc)));
3605
3606 -- Wrap any return or raise statements in Stmts in same the manner
3607 -- described in Process_Stmts.
3608
3609 Process_Stmts (Stmts);
3610
3611 -- Generate:
3612 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N
3613 -- (_Object.Comp'Address,
3614 -- Interfaces.Unsigned_N (Expected_Comp),
3615 -- Interfaces.Unsigned_N (Desired_Comp))
3616
3617 if Is_Procedure then
3618 Stmt :=
3619 Make_Exit_Statement (Loc,
3620 Condition =>
3621 Make_Function_Call (Loc,
3622 Name =>
3623 New_Occurrence_Of (Try_Write, Loc),
3624 Parameter_Associations => New_List (
3625 Make_Attribute_Reference (Loc,
3626 Prefix => Relocate_Node (Comp_Sel_Nam),
3627 Attribute_Name => Name_Address),
3628
3629 Unchecked_Convert_To (Unsigned,
3630 New_Occurrence_Of (Expected_Comp, Loc)),
3631
3632 Unchecked_Convert_To (Unsigned,
3633 New_Occurrence_Of (Desired_Comp, Loc)))));
3634
3635 -- Small optimization: transform the default return statement
3636 -- of a procedure into the atomic exit statement.
3637
3638 if Nkind (Last (Stmts)) = N_Simple_Return_Statement then
3639 Rewrite (Last (Stmts), Stmt);
3640 else
3641 Append_To (Stmts, Stmt);
3642 end if;
3643 end if;
3644
3645 -- Create the declaration of the label used to skip the rest of
3646 -- the source statements when the object state changes.
3647
3648 if Present (Label_Id) then
3649 Label := Make_Label (Loc, Label_Id);
3650 Append_To (Decls,
3651 Make_Implicit_Label_Declaration (Loc,
3652 Defining_Identifier => Entity (Label_Id),
3653 Label_Construct => Label));
3654 Append_To (Stmts, Label);
3655 end if;
3656
3657 -- Generate:
3658 -- loop
3659 -- declare
3660 -- <Decls>
3661 -- begin
3662 -- <Stmts>
3663 -- end;
3664 -- end loop;
3665
3666 if Is_Procedure then
3667 Stmts :=
3668 New_List (
3669 Make_Loop_Statement (Loc,
3670 Statements => New_List (
3671 Make_Block_Statement (Loc,
3672 Declarations => Block_Decls,
3673 Handled_Statement_Sequence =>
3674 Make_Handled_Sequence_Of_Statements (Loc,
3675 Statements => Stmts))),
3676 End_Label => Empty));
3677 end if;
3678
3679 Hand_Stmt_Seq :=
3680 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts);
3681 end Protected_Component_Ref;
3682 end if;
3683
3684 -- Make an unprotected version of the subprogram for use within the same
3685 -- object, with new name and extra parameter representing the object.
3686
3687 return
3688 Make_Subprogram_Body (Loc,
3689 Specification =>
3690 Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode),
3691 Declarations => Decls,
3692 Handled_Statement_Sequence => Hand_Stmt_Seq);
3693 end Build_Lock_Free_Unprotected_Subprogram_Body;
3694
3695 -------------------------
3696 -- Build_Master_Entity --
3697 -------------------------
3698
3699 procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is
3700 Loc : constant Source_Ptr := Sloc (Obj_Or_Typ);
3701 Context : Node_Id;
3702 Context_Id : Entity_Id;
3703 Decl : Node_Id;
3704 Decls : List_Id;
3705 Par : Node_Id;
3706
3707 begin
3708 if Is_Itype (Obj_Or_Typ) then
3709 Par := Associated_Node_For_Itype (Obj_Or_Typ);
3710 else
3711 Par := Parent (Obj_Or_Typ);
3712 end if;
3713
3714 -- When creating a master for a record component which is either a task
3715 -- or access-to-task, the enclosing record is the master scope and the
3716 -- proper insertion point is the component list.
3717
3718 if Is_Record_Type (Current_Scope) then
3719 Context := Par;
3720 Context_Id := Current_Scope;
3721 Decls := List_Containing (Context);
3722
3723 -- Default case for object declarations and access types. Note that the
3724 -- context is updated to the nearest enclosing body, block, package, or
3725 -- return statement.
3726
3727 else
3728 Find_Enclosing_Context (Par, Context, Context_Id, Decls);
3729 end if;
3730
3731 -- Do not create a master if one already exists or there is no task
3732 -- hierarchy.
3733
3734 if Has_Master_Entity (Context_Id)
3735 or else Restriction_Active (No_Task_Hierarchy)
3736 then
3737 return;
3738 end if;
3739
3740 -- Create a master, generate:
3741 -- _Master : constant Master_Id := Current_Master.all;
3742
3743 Decl :=
3744 Make_Object_Declaration (Loc,
3745 Defining_Identifier =>
3746 Make_Defining_Identifier (Loc, Name_uMaster),
3747 Constant_Present => True,
3748 Object_Definition => New_Occurrence_Of (RTE (RE_Master_Id), Loc),
3749 Expression =>
3750 Make_Explicit_Dereference (Loc,
3751 New_Occurrence_Of (RTE (RE_Current_Master), Loc)));
3752
3753 -- The master is inserted at the start of the declarative list of the
3754 -- context.
3755
3756 Prepend_To (Decls, Decl);
3757
3758 -- In certain cases where transient scopes are involved, the immediate
3759 -- scope is not always the proper master scope. Ensure that the master
3760 -- declaration and entity appear in the same context.
3761
3762 if Context_Id /= Current_Scope then
3763 Push_Scope (Context_Id);
3764 Analyze (Decl);
3765 Pop_Scope;
3766 else
3767 Analyze (Decl);
3768 end if;
3769
3770 -- Mark the enclosing scope and its associated construct as being task
3771 -- masters.
3772
3773 Set_Has_Master_Entity (Context_Id);
3774
3775 while Present (Context)
3776 and then Nkind (Context) /= N_Compilation_Unit
3777 loop
3778 if Nkind_In (Context, N_Block_Statement,
3779 N_Subprogram_Body,
3780 N_Task_Body)
3781 then
3782 Set_Is_Task_Master (Context);
3783 exit;
3784
3785 elsif Nkind (Parent (Context)) = N_Subunit then
3786 Context := Corresponding_Stub (Parent (Context));
3787 end if;
3788
3789 Context := Parent (Context);
3790 end loop;
3791 end Build_Master_Entity;
3792
3793 ---------------------------
3794 -- Build_Master_Renaming --
3795 ---------------------------
3796
3797 procedure Build_Master_Renaming
3798 (Ptr_Typ : Entity_Id;
3799 Ins_Nod : Node_Id := Empty)
3800 is
3801 Loc : constant Source_Ptr := Sloc (Ptr_Typ);
3802 Context : Node_Id;
3803 Master_Decl : Node_Id;
3804 Master_Id : Entity_Id;
3805
3806 begin
3807 -- Nothing to do if there is no task hierarchy
3808
3809 if Restriction_Active (No_Task_Hierarchy) then
3810 return;
3811 end if;
3812
3813 -- Determine the proper context to insert the master renaming
3814
3815 if Present (Ins_Nod) then
3816 Context := Ins_Nod;
3817 elsif Is_Itype (Ptr_Typ) then
3818 Context := Associated_Node_For_Itype (Ptr_Typ);
3819 else
3820 Context := Parent (Ptr_Typ);
3821 end if;
3822
3823 -- Generate:
3824 -- <Ptr_Typ>M : Master_Id renames _Master;
3825
3826 Master_Id :=
3827 Make_Defining_Identifier (Loc,
3828 New_External_Name (Chars (Ptr_Typ), 'M'));
3829
3830 Master_Decl :=
3831 Make_Object_Renaming_Declaration (Loc,
3832 Defining_Identifier => Master_Id,
3833 Subtype_Mark => New_Occurrence_Of (RTE (RE_Master_Id), Loc),
3834 Name => Make_Identifier (Loc, Name_uMaster));
3835
3836 Insert_Action (Context, Master_Decl);
3837
3838 -- The renamed master now services the access type
3839
3840 Set_Master_Id (Ptr_Typ, Master_Id);
3841 end Build_Master_Renaming;
3842
3843 -----------------------------------------
3844 -- Build_Private_Protected_Declaration --
3845 -----------------------------------------
3846
3847 function Build_Private_Protected_Declaration
3848 (N : Node_Id) return Entity_Id
3849 is
3850 Loc : constant Source_Ptr := Sloc (N);
3851 Body_Id : constant Entity_Id := Defining_Entity (N);
3852 Decl : Node_Id;
3853 Plist : List_Id;
3854 Formal : Entity_Id;
3855 New_Spec : Node_Id;
3856 Spec_Id : Entity_Id;
3857
3858 begin
3859 Formal := First_Formal (Body_Id);
3860
3861 -- The protected operation always has at least one formal, namely the
3862 -- object itself, but it is only placed in the parameter list if
3863 -- expansion is enabled.
3864
3865 if Present (Formal) or else Expander_Active then
3866 Plist := Copy_Parameter_List (Body_Id);
3867 else
3868 Plist := No_List;
3869 end if;
3870
3871 if Nkind (Specification (N)) = N_Procedure_Specification then
3872 New_Spec :=
3873 Make_Procedure_Specification (Loc,
3874 Defining_Unit_Name =>
3875 Make_Defining_Identifier (Sloc (Body_Id),
3876 Chars => Chars (Body_Id)),
3877 Parameter_Specifications =>
3878 Plist);
3879 else
3880 New_Spec :=
3881 Make_Function_Specification (Loc,
3882 Defining_Unit_Name =>
3883 Make_Defining_Identifier (Sloc (Body_Id),
3884 Chars => Chars (Body_Id)),
3885 Parameter_Specifications => Plist,
3886 Result_Definition =>
3887 New_Occurrence_Of (Etype (Body_Id), Loc));
3888 end if;
3889
3890 Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec);
3891 Insert_Before (N, Decl);
3892 Spec_Id := Defining_Unit_Name (New_Spec);
3893
3894 -- Indicate that the entity comes from source, to ensure that cross-
3895 -- reference information is properly generated. The body itself is
3896 -- rewritten during expansion, and the body entity will not appear in
3897 -- calls to the operation.
3898
3899 Set_Comes_From_Source (Spec_Id, True);
3900 Analyze (Decl);
3901 Set_Has_Completion (Spec_Id);
3902 Set_Convention (Spec_Id, Convention_Protected);
3903 return Spec_Id;
3904 end Build_Private_Protected_Declaration;
3905
3906 ---------------------------
3907 -- Build_Protected_Entry --
3908 ---------------------------
3909
3910 function Build_Protected_Entry
3911 (N : Node_Id;
3912 Ent : Entity_Id;
3913 Pid : Node_Id) return Node_Id
3914 is
3915 Bod_Decls : constant List_Id := New_List;
3916 Decls : constant List_Id := Declarations (N);
3917 End_Lab : constant Node_Id :=
3918 End_Label (Handled_Statement_Sequence (N));
3919 End_Loc : constant Source_Ptr :=
3920 Sloc (Last (Statements (Handled_Statement_Sequence (N))));
3921 -- Used for the generated call to Complete_Entry_Body
3922
3923 Loc : constant Source_Ptr := Sloc (N);
3924
3925 Bod_Id : Entity_Id;
3926 Bod_Spec : Node_Id;
3927 Bod_Stmts : List_Id;
3928 Complete : Node_Id;
3929 Ohandle : Node_Id;
3930
3931 EH_Loc : Source_Ptr;
3932 -- Used for the exception handler, inserted at end of the body
3933
3934 begin
3935 -- Set the source location on the exception handler only when debugging
3936 -- the expanded code (see Make_Implicit_Exception_Handler).
3937
3938 if Debug_Generated_Code then
3939 EH_Loc := End_Loc;
3940
3941 -- Otherwise the inserted code should not be visible to the debugger
3942
3943 else
3944 EH_Loc := No_Location;
3945 end if;
3946
3947 Bod_Id :=
3948 Make_Defining_Identifier (Loc,
3949 Chars => Chars (Protected_Body_Subprogram (Ent)));
3950 Bod_Spec := Build_Protected_Entry_Specification (Loc, Bod_Id, Empty);
3951
3952 -- Add the following declarations:
3953
3954 -- type poVP is access poV;
3955 -- _object : poVP := poVP (_O);
3956
3957 -- where _O is the formal parameter associated with the concurrent
3958 -- object. These declarations are needed for Complete_Entry_Body.
3959
3960 Add_Object_Pointer (Loc, Pid, Bod_Decls);
3961
3962 -- Add renamings for all formals, the Protection object, discriminals,
3963 -- privals and the entry index constant for use by debugger.
3964
3965 Add_Formal_Renamings (Bod_Spec, Bod_Decls, Ent, Loc);
3966 Debug_Private_Data_Declarations (Decls);
3967
3968 -- Put the declarations and the statements from the entry
3969
3970 Bod_Stmts :=
3971 New_List (
3972 Make_Block_Statement (Loc,
3973 Declarations => Decls,
3974 Handled_Statement_Sequence => Handled_Statement_Sequence (N)));
3975
3976 case Corresponding_Runtime_Package (Pid) is
3977 when System_Tasking_Protected_Objects_Entries =>
3978 Append_To (Bod_Stmts,
3979 Make_Procedure_Call_Statement (End_Loc,
3980 Name =>
3981 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc),
3982 Parameter_Associations => New_List (
3983 Make_Attribute_Reference (End_Loc,
3984 Prefix =>
3985 Make_Selected_Component (End_Loc,
3986 Prefix =>
3987 Make_Identifier (End_Loc, Name_uObject),
3988 Selector_Name =>
3989 Make_Identifier (End_Loc, Name_uObject)),
3990 Attribute_Name => Name_Unchecked_Access))));
3991
3992 when System_Tasking_Protected_Objects_Single_Entry =>
3993
3994 -- Historically, a call to Complete_Single_Entry_Body was
3995 -- inserted, but it was a null procedure.
3996
3997 null;
3998
3999 when others =>
4000 raise Program_Error;
4001 end case;
4002
4003 -- When exceptions can not be propagated, we never need to call
4004 -- Exception_Complete_Entry_Body.
4005
4006 if No_Exception_Handlers_Set then
4007 return
4008 Make_Subprogram_Body (Loc,
4009 Specification => Bod_Spec,
4010 Declarations => Bod_Decls,
4011 Handled_Statement_Sequence =>
4012 Make_Handled_Sequence_Of_Statements (Loc,
4013 Statements => Bod_Stmts,
4014 End_Label => End_Lab));
4015
4016 else
4017 Ohandle := Make_Others_Choice (Loc);
4018 Set_All_Others (Ohandle);
4019
4020 case Corresponding_Runtime_Package (Pid) is
4021 when System_Tasking_Protected_Objects_Entries =>
4022 Complete :=
4023 New_Occurrence_Of
4024 (RTE (RE_Exceptional_Complete_Entry_Body), Loc);
4025
4026 when System_Tasking_Protected_Objects_Single_Entry =>
4027 Complete :=
4028 New_Occurrence_Of
4029 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc);
4030
4031 when others =>
4032 raise Program_Error;
4033 end case;
4034
4035 -- Establish link between subprogram body entity and source entry
4036
4037 Set_Corresponding_Protected_Entry (Bod_Id, Ent);
4038
4039 -- Create body of entry procedure. The renaming declarations are
4040 -- placed ahead of the block that contains the actual entry body.
4041
4042 return
4043 Make_Subprogram_Body (Loc,
4044 Specification => Bod_Spec,
4045 Declarations => Bod_Decls,
4046 Handled_Statement_Sequence =>
4047 Make_Handled_Sequence_Of_Statements (Loc,
4048 Statements => Bod_Stmts,
4049 End_Label => End_Lab,
4050 Exception_Handlers => New_List (
4051 Make_Implicit_Exception_Handler (EH_Loc,
4052 Exception_Choices => New_List (Ohandle),
4053
4054 Statements => New_List (
4055 Make_Procedure_Call_Statement (EH_Loc,
4056 Name => Complete,
4057 Parameter_Associations => New_List (
4058 Make_Attribute_Reference (EH_Loc,
4059 Prefix =>
4060 Make_Selected_Component (EH_Loc,
4061 Prefix =>
4062 Make_Identifier (EH_Loc, Name_uObject),
4063 Selector_Name =>
4064 Make_Identifier (EH_Loc, Name_uObject)),
4065 Attribute_Name => Name_Unchecked_Access),
4066
4067 Make_Function_Call (EH_Loc,
4068 Name =>
4069 New_Occurrence_Of
4070 (RTE (RE_Get_GNAT_Exception), Loc)))))))));
4071 end if;
4072 end Build_Protected_Entry;
4073
4074 -----------------------------------------
4075 -- Build_Protected_Entry_Specification --
4076 -----------------------------------------
4077
4078 function Build_Protected_Entry_Specification
4079 (Loc : Source_Ptr;
4080 Def_Id : Entity_Id;
4081 Ent_Id : Entity_Id) return Node_Id
4082 is
4083 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP);
4084
4085 begin
4086 Set_Debug_Info_Needed (Def_Id);
4087
4088 if Present (Ent_Id) then
4089 Append_Elmt (P, Accept_Address (Ent_Id));
4090 end if;
4091
4092 return
4093 Make_Procedure_Specification (Loc,
4094 Defining_Unit_Name => Def_Id,
4095 Parameter_Specifications => New_List (
4096 Make_Parameter_Specification (Loc,
4097 Defining_Identifier =>
4098 Make_Defining_Identifier (Loc, Name_uO),
4099 Parameter_Type =>
4100 New_Occurrence_Of (RTE (RE_Address), Loc)),
4101
4102 Make_Parameter_Specification (Loc,
4103 Defining_Identifier => P,
4104 Parameter_Type =>
4105 New_Occurrence_Of (RTE (RE_Address), Loc)),
4106
4107 Make_Parameter_Specification (Loc,
4108 Defining_Identifier =>
4109 Make_Defining_Identifier (Loc, Name_uE),
4110 Parameter_Type =>
4111 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))));
4112 end Build_Protected_Entry_Specification;
4113
4114 --------------------------
4115 -- Build_Protected_Spec --
4116 --------------------------
4117
4118 function Build_Protected_Spec
4119 (N : Node_Id;
4120 Obj_Type : Entity_Id;
4121 Ident : Entity_Id;
4122 Unprotected : Boolean := False) return List_Id
4123 is
4124 Loc : constant Source_Ptr := Sloc (N);
4125 Decl : Node_Id;
4126 Formal : Entity_Id;
4127 New_Plist : List_Id;
4128 New_Param : Node_Id;
4129
4130 begin
4131 New_Plist := New_List;
4132
4133 Formal := First_Formal (Ident);
4134 while Present (Formal) loop
4135 New_Param :=
4136 Make_Parameter_Specification (Loc,
4137 Defining_Identifier =>
4138 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
4139 Aliased_Present => Aliased_Present (Parent (Formal)),
4140 In_Present => In_Present (Parent (Formal)),
4141 Out_Present => Out_Present (Parent (Formal)),
4142 Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc));
4143
4144 if Unprotected then
4145 Set_Protected_Formal (Formal, Defining_Identifier (New_Param));
4146 end if;
4147
4148 Append (New_Param, New_Plist);
4149 Next_Formal (Formal);
4150 end loop;
4151
4152 -- If the subprogram is a procedure and the context is not an access
4153 -- to protected subprogram, the parameter is in-out. Otherwise it is
4154 -- an in parameter.
4155
4156 Decl :=
4157 Make_Parameter_Specification (Loc,
4158 Defining_Identifier =>
4159 Make_Defining_Identifier (Loc, Name_uObject),
4160 In_Present => True,
4161 Out_Present =>
4162 (Etype (Ident) = Standard_Void_Type
4163 and then not Is_RTE (Obj_Type, RE_Address)),
4164 Parameter_Type =>
4165 New_Occurrence_Of (Obj_Type, Loc));
4166 Set_Debug_Info_Needed (Defining_Identifier (Decl));
4167 Prepend_To (New_Plist, Decl);
4168
4169 return New_Plist;
4170 end Build_Protected_Spec;
4171
4172 ---------------------------------------
4173 -- Build_Protected_Sub_Specification --
4174 ---------------------------------------
4175
4176 function Build_Protected_Sub_Specification
4177 (N : Node_Id;
4178 Prot_Typ : Entity_Id;
4179 Mode : Subprogram_Protection_Mode) return Node_Id
4180 is
4181 Loc : constant Source_Ptr := Sloc (N);
4182 Decl : Node_Id;
4183 Def_Id : Entity_Id;
4184 New_Id : Entity_Id;
4185 New_Plist : List_Id;
4186 New_Spec : Node_Id;
4187
4188 Append_Chr : constant array (Subprogram_Protection_Mode) of Character :=
4189 (Dispatching_Mode => ' ',
4190 Protected_Mode => 'P',
4191 Unprotected_Mode => 'N');
4192
4193 begin
4194 if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
4195 then
4196 Decl := Unit_Declaration_Node (Corresponding_Spec (N));
4197 else
4198 Decl := N;
4199 end if;
4200
4201 Def_Id := Defining_Unit_Name (Specification (Decl));
4202
4203 New_Plist :=
4204 Build_Protected_Spec
4205 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id,
4206 Mode = Unprotected_Mode);
4207 New_Id :=
4208 Make_Defining_Identifier (Loc,
4209 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode)));
4210
4211 -- Reference the original nondispatching subprogram since the analysis
4212 -- of the object.operation notation may need its original name (see
4213 -- Sem_Ch4.Names_Match).
4214
4215 if Mode = Dispatching_Mode then
4216 Set_Ekind (New_Id, Ekind (Def_Id));
4217 Set_Original_Protected_Subprogram (New_Id, Def_Id);
4218 end if;
4219
4220 -- The unprotected operation carries the user code, and debugging
4221 -- information must be generated for it, even though this spec does
4222 -- not come from source. It is also convenient to allow gdb to step
4223 -- into the protected operation, even though it only contains lock/
4224 -- unlock calls.
4225
4226 Set_Debug_Info_Needed (New_Id);
4227
4228 -- If a pragma Eliminate applies to the source entity, the internal
4229 -- subprograms will be eliminated as well.
4230
4231 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id));
4232
4233 if Nkind (Specification (Decl)) = N_Procedure_Specification then
4234 New_Spec :=
4235 Make_Procedure_Specification (Loc,
4236 Defining_Unit_Name => New_Id,
4237 Parameter_Specifications => New_Plist);
4238
4239 -- Create a new specification for the anonymous subprogram type
4240
4241 else
4242 New_Spec :=
4243 Make_Function_Specification (Loc,
4244 Defining_Unit_Name => New_Id,
4245 Parameter_Specifications => New_Plist,
4246 Result_Definition =>
4247 Copy_Result_Type (Result_Definition (Specification (Decl))));
4248
4249 Set_Return_Present (Defining_Unit_Name (New_Spec));
4250 end if;
4251
4252 return New_Spec;
4253 end Build_Protected_Sub_Specification;
4254
4255 -------------------------------------
4256 -- Build_Protected_Subprogram_Body --
4257 -------------------------------------
4258
4259 function Build_Protected_Subprogram_Body
4260 (N : Node_Id;
4261 Pid : Node_Id;
4262 N_Op_Spec : Node_Id) return Node_Id
4263 is
4264 Loc : constant Source_Ptr := Sloc (N);
4265 Op_Spec : Node_Id;
4266 P_Op_Spec : Node_Id;
4267 Uactuals : List_Id;
4268 Pformal : Node_Id;
4269 Unprot_Call : Node_Id;
4270 Sub_Body : Node_Id;
4271 Lock_Name : Node_Id;
4272 Lock_Stmt : Node_Id;
4273 R : Node_Id;
4274 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
4275 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
4276 Stmts : List_Id;
4277 Object_Parm : Node_Id;
4278 Exc_Safe : Boolean;
4279 Lock_Kind : RE_Id;
4280
4281 begin
4282 Op_Spec := Specification (N);
4283 Exc_Safe := Is_Exception_Safe (N);
4284
4285 P_Op_Spec :=
4286 Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
4287
4288 -- Build a list of the formal parameters of the protected version of
4289 -- the subprogram to use as the actual parameters of the unprotected
4290 -- version.
4291
4292 Uactuals := New_List;
4293 Pformal := First (Parameter_Specifications (P_Op_Spec));
4294 while Present (Pformal) loop
4295 Append_To (Uactuals,
4296 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))));
4297 Next (Pformal);
4298 end loop;
4299
4300 -- Make a call to the unprotected version of the subprogram built above
4301 -- for use by the protected version built below.
4302
4303 if Nkind (Op_Spec) = N_Function_Specification then
4304 if Exc_Safe then
4305 R := Make_Temporary (Loc, 'R');
4306
4307 Unprot_Call :=
4308 Make_Object_Declaration (Loc,
4309 Defining_Identifier => R,
4310 Constant_Present => True,
4311 Object_Definition =>
4312 New_Copy (Result_Definition (N_Op_Spec)),
4313 Expression =>
4314 Make_Function_Call (Loc,
4315 Name =>
4316 Make_Identifier (Loc,
4317 Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
4318 Parameter_Associations => Uactuals));
4319
4320 Return_Stmt :=
4321 Make_Simple_Return_Statement (Loc,
4322 Expression => New_Occurrence_Of (R, Loc));
4323
4324 else
4325 Unprot_Call :=
4326 Make_Simple_Return_Statement (Loc,
4327 Expression =>
4328 Make_Function_Call (Loc,
4329 Name =>
4330 Make_Identifier (Loc,
4331 Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
4332 Parameter_Associations => Uactuals));
4333 end if;
4334
4335 Lock_Kind := RE_Lock_Read_Only;
4336
4337 else
4338 Unprot_Call :=
4339 Make_Procedure_Call_Statement (Loc,
4340 Name =>
4341 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
4342 Parameter_Associations => Uactuals);
4343
4344 Lock_Kind := RE_Lock;
4345 end if;
4346
4347 -- Wrap call in block that will be covered by an at_end handler
4348
4349 if not Exc_Safe then
4350 Unprot_Call :=
4351 Make_Block_Statement (Loc,
4352 Handled_Statement_Sequence =>
4353 Make_Handled_Sequence_Of_Statements (Loc,
4354 Statements => New_List (Unprot_Call)));
4355 end if;
4356
4357 -- Make the protected subprogram body. This locks the protected
4358 -- object and calls the unprotected version of the subprogram.
4359
4360 case Corresponding_Runtime_Package (Pid) is
4361 when System_Tasking_Protected_Objects_Entries =>
4362 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc);
4363
4364 when System_Tasking_Protected_Objects_Single_Entry =>
4365 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc);
4366
4367 when System_Tasking_Protected_Objects =>
4368 Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc);
4369
4370 when others =>
4371 raise Program_Error;
4372 end case;
4373
4374 Object_Parm :=
4375 Make_Attribute_Reference (Loc,
4376 Prefix =>
4377 Make_Selected_Component (Loc,
4378 Prefix => Make_Identifier (Loc, Name_uObject),
4379 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4380 Attribute_Name => Name_Unchecked_Access);
4381
4382 Lock_Stmt :=
4383 Make_Procedure_Call_Statement (Loc,
4384 Name => Lock_Name,
4385 Parameter_Associations => New_List (Object_Parm));
4386
4387 if Abort_Allowed then
4388 Stmts := New_List (
4389 Build_Runtime_Call (Loc, RE_Abort_Defer),
4390 Lock_Stmt);
4391
4392 else
4393 Stmts := New_List (Lock_Stmt);
4394 end if;
4395
4396 if not Exc_Safe then
4397 Append (Unprot_Call, Stmts);
4398 else
4399 if Nkind (Op_Spec) = N_Function_Specification then
4400 Pre_Stmts := Stmts;
4401 Stmts := Empty_List;
4402 else
4403 Append (Unprot_Call, Stmts);
4404 end if;
4405
4406 -- Historical note: Previously, call to the cleanup was inserted
4407 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
4408 -- which is also shared by the 'not Exc_Safe' path.
4409
4410 Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts);
4411
4412 if Nkind (Op_Spec) = N_Function_Specification then
4413 Append_To (Stmts, Return_Stmt);
4414 Append_To (Pre_Stmts,
4415 Make_Block_Statement (Loc,
4416 Declarations => New_List (Unprot_Call),
4417 Handled_Statement_Sequence =>
4418 Make_Handled_Sequence_Of_Statements (Loc,
4419 Statements => Stmts)));
4420 Stmts := Pre_Stmts;
4421 end if;
4422 end if;
4423
4424 Sub_Body :=
4425 Make_Subprogram_Body (Loc,
4426 Declarations => Empty_List,
4427 Specification => P_Op_Spec,
4428 Handled_Statement_Sequence =>
4429 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
4430
4431 -- Mark this subprogram as a protected subprogram body so that the
4432 -- cleanup will be inserted. This is done only in the 'not Exc_Safe'
4433 -- path as otherwise the cleanup has already been inserted.
4434
4435 if not Exc_Safe then
4436 Set_Is_Protected_Subprogram_Body (Sub_Body);
4437 end if;
4438
4439 return Sub_Body;
4440 end Build_Protected_Subprogram_Body;
4441
4442 -------------------------------------
4443 -- Build_Protected_Subprogram_Call --
4444 -------------------------------------
4445
4446 procedure Build_Protected_Subprogram_Call
4447 (N : Node_Id;
4448 Name : Node_Id;
4449 Rec : Node_Id;
4450 External : Boolean := True)
4451 is
4452 Loc : constant Source_Ptr := Sloc (N);
4453 Sub : constant Entity_Id := Entity (Name);
4454 New_Sub : Node_Id;
4455 Params : List_Id;
4456
4457 begin
4458 if External then
4459 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc);
4460 else
4461 New_Sub :=
4462 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc);
4463 end if;
4464
4465 if Present (Parameter_Associations (N)) then
4466 Params := New_Copy_List_Tree (Parameter_Associations (N));
4467 else
4468 Params := New_List;
4469 end if;
4470
4471 -- If the type is an untagged derived type, convert to the root type,
4472 -- which is the one on which the operations are defined.
4473
4474 if Nkind (Rec) = N_Unchecked_Type_Conversion
4475 and then not Is_Tagged_Type (Etype (Rec))
4476 and then Is_Derived_Type (Etype (Rec))
4477 then
4478 Set_Etype (Rec, Root_Type (Etype (Rec)));
4479 Set_Subtype_Mark (Rec,
4480 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N)));
4481 end if;
4482
4483 Prepend (Rec, Params);
4484
4485 if Ekind (Sub) = E_Procedure then
4486 Rewrite (N,
4487 Make_Procedure_Call_Statement (Loc,
4488 Name => New_Sub,
4489 Parameter_Associations => Params));
4490
4491 else
4492 pragma Assert (Ekind (Sub) = E_Function);
4493 Rewrite (N,
4494 Make_Function_Call (Loc,
4495 Name => New_Sub,
4496 Parameter_Associations => Params));
4497
4498 -- Preserve type of call for subsequent processing (required for
4499 -- call to Wrap_Transient_Expression in the case of a shared passive
4500 -- protected).
4501
4502 Set_Etype (N, Etype (New_Sub));
4503 end if;
4504
4505 if External
4506 and then Nkind (Rec) = N_Unchecked_Type_Conversion
4507 and then Is_Entity_Name (Expression (Rec))
4508 and then Is_Shared_Passive (Entity (Expression (Rec)))
4509 then
4510 Add_Shared_Var_Lock_Procs (N);
4511 end if;
4512 end Build_Protected_Subprogram_Call;
4513
4514 ---------------------------------------------
4515 -- Build_Protected_Subprogram_Call_Cleanup --
4516 ---------------------------------------------
4517
4518 procedure Build_Protected_Subprogram_Call_Cleanup
4519 (Op_Spec : Node_Id;
4520 Conc_Typ : Node_Id;
4521 Loc : Source_Ptr;
4522 Stmts : List_Id)
4523 is
4524 Nam : Node_Id;
4525
4526 begin
4527 -- If the associated protected object has entries, a protected
4528 -- procedure has to service entry queues. In this case generate:
4529
4530 -- Service_Entries (_object._object'Access);
4531
4532 if Nkind (Op_Spec) = N_Procedure_Specification
4533 and then Has_Entries (Conc_Typ)
4534 then
4535 case Corresponding_Runtime_Package (Conc_Typ) is
4536 when System_Tasking_Protected_Objects_Entries =>
4537 Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc);
4538
4539 when System_Tasking_Protected_Objects_Single_Entry =>
4540 Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc);
4541
4542 when others =>
4543 raise Program_Error;
4544 end case;
4545
4546 Append_To (Stmts,
4547 Make_Procedure_Call_Statement (Loc,
4548 Name => Nam,
4549 Parameter_Associations => New_List (
4550 Make_Attribute_Reference (Loc,
4551 Prefix =>
4552 Make_Selected_Component (Loc,
4553 Prefix => Make_Identifier (Loc, Name_uObject),
4554 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4555 Attribute_Name => Name_Unchecked_Access))));
4556
4557 else
4558 -- Generate:
4559 -- Unlock (_object._object'Access);
4560
4561 case Corresponding_Runtime_Package (Conc_Typ) is
4562 when System_Tasking_Protected_Objects_Entries =>
4563 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc);
4564
4565 when System_Tasking_Protected_Objects_Single_Entry =>
4566 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc);
4567
4568 when System_Tasking_Protected_Objects =>
4569 Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc);
4570
4571 when others =>
4572 raise Program_Error;
4573 end case;
4574
4575 Append_To (Stmts,
4576 Make_Procedure_Call_Statement (Loc,
4577 Name => Nam,
4578 Parameter_Associations => New_List (
4579 Make_Attribute_Reference (Loc,
4580 Prefix =>
4581 Make_Selected_Component (Loc,
4582 Prefix => Make_Identifier (Loc, Name_uObject),
4583 Selector_Name => Make_Identifier (Loc, Name_uObject)),
4584 Attribute_Name => Name_Unchecked_Access))));
4585 end if;
4586
4587 -- Generate:
4588 -- Abort_Undefer;
4589
4590 if Abort_Allowed then
4591 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
4592 end if;
4593 end Build_Protected_Subprogram_Call_Cleanup;
4594
4595 -------------------------
4596 -- Build_Selected_Name --
4597 -------------------------
4598
4599 function Build_Selected_Name
4600 (Prefix : Entity_Id;
4601 Selector : Entity_Id;
4602 Append_Char : Character := ' ') return Name_Id
4603 is
4604 Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
4605 Select_Len : Natural;
4606
4607 begin
4608 Get_Name_String (Chars (Selector));
4609 Select_Len := Name_Len;
4610 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len);
4611 Get_Name_String (Chars (Prefix));
4612
4613 -- If scope is anonymous type, discard suffix to recover name of
4614 -- single protected object. Otherwise use protected type name.
4615
4616 if Name_Buffer (Name_Len) = 'T' then
4617 Name_Len := Name_Len - 1;
4618 end if;
4619
4620 Add_Str_To_Name_Buffer ("__");
4621 for J in 1 .. Select_Len loop
4622 Add_Char_To_Name_Buffer (Select_Buffer (J));
4623 end loop;
4624
4625 -- Now add the Append_Char if specified. The encoding to follow
4626 -- depends on the type of entity. If Append_Char is either 'N' or 'P',
4627 -- then the entity is associated to a protected type subprogram.
4628 -- Otherwise, it is a protected type entry. For each case, the
4629 -- encoding to follow for the suffix is documented in exp_dbug.ads.
4630
4631 -- It would be better to encapsulate this as a routine in Exp_Dbug ???
4632
4633 if Append_Char /= ' ' then
4634 if Append_Char = 'P' or Append_Char = 'N' then
4635 Add_Char_To_Name_Buffer (Append_Char);
4636 return Name_Find;
4637 else
4638 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char));
4639 return New_External_Name (Name_Find, ' ', -1);
4640 end if;
4641 else
4642 return Name_Find;
4643 end if;
4644 end Build_Selected_Name;
4645
4646 -----------------------------
4647 -- Build_Simple_Entry_Call --
4648 -----------------------------
4649
4650 -- A task entry call is converted to a call to Call_Simple
4651
4652 -- declare
4653 -- P : parms := (parm, parm, parm);
4654 -- begin
4655 -- Call_Simple (acceptor-task, entry-index, P'Address);
4656 -- parm := P.param;
4657 -- parm := P.param;
4658 -- ...
4659 -- end;
4660
4661 -- Here Pnn is an aggregate of the type constructed for the entry to hold
4662 -- the parameters, and the constructed aggregate value contains either the
4663 -- parameters or, in the case of non-elementary types, references to these
4664 -- parameters. Then the address of this aggregate is passed to the runtime
4665 -- routine, along with the task id value and the task entry index value.
4666 -- Pnn is only required if parameters are present.
4667
4668 -- The assignments after the call are present only in the case of in-out
4669 -- or out parameters for elementary types, and are used to assign back the
4670 -- resulting values of such parameters.
4671
4672 -- Note: the reason that we insert a block here is that in the context
4673 -- of selects, conditional entry calls etc. the entry call statement
4674 -- appears on its own, not as an element of a list.
4675
4676 -- A protected entry call is converted to a Protected_Entry_Call:
4677
4678 -- declare
4679 -- P : E1_Params := (param, param, param);
4680 -- Pnn : Boolean;
4681 -- Bnn : Communications_Block;
4682
4683 -- declare
4684 -- P : E1_Params := (param, param, param);
4685 -- Bnn : Communications_Block;
4686
4687 -- begin
4688 -- Protected_Entry_Call (
4689 -- Object => po._object'Access,
4690 -- E => <entry index>;
4691 -- Uninterpreted_Data => P'Address;
4692 -- Mode => Simple_Call;
4693 -- Block => Bnn);
4694 -- parm := P.param;
4695 -- parm := P.param;
4696 -- ...
4697 -- end;
4698
4699 procedure Build_Simple_Entry_Call
4700 (N : Node_Id;
4701 Concval : Node_Id;
4702 Ename : Node_Id;
4703 Index : Node_Id)
4704 is
4705 begin
4706 Expand_Call (N);
4707
4708 -- If call has been inlined, nothing left to do
4709
4710 if Nkind (N) = N_Block_Statement then
4711 return;
4712 end if;
4713
4714 -- Convert entry call to Call_Simple call
4715
4716 declare
4717 Loc : constant Source_Ptr := Sloc (N);
4718 Parms : constant List_Id := Parameter_Associations (N);
4719 Stats : constant List_Id := New_List;
4720 Actual : Node_Id;
4721 Call : Node_Id;
4722 Comm_Name : Entity_Id;
4723 Conctyp : Node_Id;
4724 Decls : List_Id;
4725 Ent : Entity_Id;
4726 Ent_Acc : Entity_Id;
4727 Formal : Node_Id;
4728 Iface_Tag : Entity_Id;
4729 Iface_Typ : Entity_Id;
4730 N_Node : Node_Id;
4731 N_Var : Node_Id;
4732 P : Entity_Id;
4733 Parm1 : Node_Id;
4734 Parm2 : Node_Id;
4735 Parm3 : Node_Id;
4736 Pdecl : Node_Id;
4737 Plist : List_Id;
4738 X : Entity_Id;
4739 Xdecl : Node_Id;
4740
4741 begin
4742 -- Simple entry and entry family cases merge here
4743
4744 Ent := Entity (Ename);
4745 Ent_Acc := Entry_Parameters_Type (Ent);
4746 Conctyp := Etype (Concval);
4747
4748 -- If prefix is an access type, dereference to obtain the task type
4749
4750 if Is_Access_Type (Conctyp) then
4751 Conctyp := Designated_Type (Conctyp);
4752 end if;
4753
4754 -- Special case for protected subprogram calls
4755
4756 if Is_Protected_Type (Conctyp)
4757 and then Is_Subprogram (Entity (Ename))
4758 then
4759 if not Is_Eliminated (Entity (Ename)) then
4760 Build_Protected_Subprogram_Call
4761 (N, Ename, Convert_Concurrent (Concval, Conctyp));
4762 Analyze (N);
4763 end if;
4764
4765 return;
4766 end if;
4767
4768 -- First parameter is the Task_Id value from the task value or the
4769 -- Object from the protected object value, obtained by selecting
4770 -- the _Task_Id or _Object from the result of doing an unchecked
4771 -- conversion to convert the value to the corresponding record type.
4772
4773 if Nkind (Concval) = N_Function_Call
4774 and then Is_Task_Type (Conctyp)
4775 and then Ada_Version >= Ada_2005
4776 then
4777 declare
4778 ExpR : constant Node_Id := Relocate_Node (Concval);
4779 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR);
4780 Decl : Node_Id;
4781
4782 begin
4783 Decl :=
4784 Make_Object_Declaration (Loc,
4785 Defining_Identifier => Obj,
4786 Object_Definition => New_Occurrence_Of (Conctyp, Loc),
4787 Expression => ExpR);
4788 Set_Etype (Obj, Conctyp);
4789 Decls := New_List (Decl);
4790 Rewrite (Concval, New_Occurrence_Of (Obj, Loc));
4791 end;
4792
4793 else
4794 Decls := New_List;
4795 end if;
4796
4797 Parm1 := Concurrent_Ref (Concval);
4798
4799 -- Second parameter is the entry index, computed by the routine
4800 -- provided for this purpose. The value of this expression is
4801 -- assigned to an intermediate variable to assure that any entry
4802 -- family index expressions are evaluated before the entry
4803 -- parameters.
4804
4805 if not Is_Protected_Type (Conctyp)
4806 or else
4807 Corresponding_Runtime_Package (Conctyp) =
4808 System_Tasking_Protected_Objects_Entries
4809 then
4810 X := Make_Defining_Identifier (Loc, Name_uX);
4811
4812 Xdecl :=
4813 Make_Object_Declaration (Loc,
4814 Defining_Identifier => X,
4815 Object_Definition =>
4816 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc),
4817 Expression => Actual_Index_Expression (
4818 Loc, Entity (Ename), Index, Concval));
4819
4820 Append_To (Decls, Xdecl);
4821 Parm2 := New_Occurrence_Of (X, Loc);
4822
4823 else
4824 Xdecl := Empty;
4825 Parm2 := Empty;
4826 end if;
4827
4828 -- The third parameter is the packaged parameters. If there are
4829 -- none, then it is just the null address, since nothing is passed.
4830
4831 if No (Parms) then
4832 Parm3 := New_Occurrence_Of (RTE (RE_Null_Address), Loc);
4833 P := Empty;
4834
4835 -- Case of parameters present, where third argument is the address
4836 -- of a packaged record containing the required parameter values.
4837
4838 else
4839 -- First build a list of parameter values, which are references to
4840 -- objects of the parameter types.
4841
4842 Plist := New_List;
4843
4844 Actual := First_Actual (N);
4845 Formal := First_Formal (Ent);
4846 while Present (Actual) loop
4847
4848 -- If it is a by-copy type, copy it to a new variable. The
4849 -- packaged record has a field that points to this variable.
4850
4851 if Is_By_Copy_Type (Etype (Actual)) then
4852 N_Node :=
4853 Make_Object_Declaration (Loc,
4854 Defining_Identifier => Make_Temporary (Loc, 'J'),
4855 Aliased_Present => True,
4856 Object_Definition =>
4857 New_Occurrence_Of (Etype (Formal), Loc));
4858
4859 -- Mark the object as not needing initialization since the
4860 -- initialization is performed separately, avoiding errors
4861 -- on cases such as formals of null-excluding access types.
4862
4863 Set_No_Initialization (N_Node);
4864
4865 -- We must make a separate assignment statement for the
4866 -- case of limited types. We cannot assign it unless the
4867 -- Assignment_OK flag is set first. An out formal of an
4868 -- access type or whose type has a Default_Value must also
4869 -- be initialized from the actual (see RM 6.4.1 (13-13.1)),
4870 -- but no constraint, predicate, or null-exclusion check is
4871 -- applied before the call.
4872
4873 if Ekind (Formal) /= E_Out_Parameter
4874 or else Is_Access_Type (Etype (Formal))
4875 or else
4876 (Is_Scalar_Type (Etype (Formal))
4877 and then
4878 Present (Default_Aspect_Value (Etype (Formal))))
4879 then
4880 N_Var :=
4881 New_Occurrence_Of (Defining_Identifier (N_Node), Loc);
4882 Set_Assignment_OK (N_Var);
4883 Append_To (Stats,
4884 Make_Assignment_Statement (Loc,
4885 Name => N_Var,
4886 Expression => Relocate_Node (Actual)));
4887
4888 -- Mark the object as internal, so we don't later reset
4889 -- No_Initialization flag in Default_Initialize_Object,
4890 -- which would lead to needless default initialization.
4891 -- We don't set this outside the if statement, because
4892 -- out scalar parameters without Default_Value do require
4893 -- default initialization if Initialize_Scalars applies.
4894
4895 Set_Is_Internal (Defining_Identifier (N_Node));
4896
4897 -- If actual is an out parameter of a null-excluding
4898 -- access type, there is access check on entry, so set
4899 -- Suppress_Assignment_Checks on the generated statement
4900 -- that assigns the actual to the parameter block
4901
4902 Set_Suppress_Assignment_Checks (Last (Stats));
4903 end if;
4904
4905 Append (N_Node, Decls);
4906
4907 Append_To (Plist,
4908 Make_Attribute_Reference (Loc,
4909 Attribute_Name => Name_Unchecked_Access,
4910 Prefix =>
4911 New_Occurrence_Of
4912 (Defining_Identifier (N_Node), Loc)));
4913
4914 else
4915 -- Interface class-wide formal
4916
4917 if Ada_Version >= Ada_2005
4918 and then Ekind (Etype (Formal)) = E_Class_Wide_Type
4919 and then Is_Interface (Etype (Formal))
4920 then
4921 Iface_Typ := Etype (Etype (Formal));
4922
4923 -- Generate:
4924 -- formal_iface_type! (actual.iface_tag)'reference
4925
4926 Iface_Tag :=
4927 Find_Interface_Tag (Etype (Actual), Iface_Typ);
4928 pragma Assert (Present (Iface_Tag));
4929
4930 Append_To (Plist,
4931 Make_Reference (Loc,
4932 Unchecked_Convert_To (Iface_Typ,
4933 Make_Selected_Component (Loc,
4934 Prefix =>
4935 Relocate_Node (Actual),
4936 Selector_Name =>
4937 New_Occurrence_Of (Iface_Tag, Loc)))));
4938 else
4939 -- Generate:
4940 -- actual'reference
4941
4942 Append_To (Plist,
4943 Make_Reference (Loc, Relocate_Node (Actual)));
4944 end if;
4945 end if;
4946
4947 Next_Actual (Actual);
4948 Next_Formal_With_Extras (Formal);
4949 end loop;
4950
4951 -- Now build the declaration of parameters initialized with the
4952 -- aggregate containing this constructed parameter list.
4953
4954 P := Make_Defining_Identifier (Loc, Name_uP);
4955
4956 Pdecl :=
4957 Make_Object_Declaration (Loc,
4958 Defining_Identifier => P,
4959 Object_Definition =>
4960 New_Occurrence_Of (Designated_Type (Ent_Acc), Loc),
4961 Expression =>
4962 Make_Aggregate (Loc, Expressions => Plist));
4963
4964 Parm3 :=
4965 Make_Attribute_Reference (Loc,
4966 Prefix => New_Occurrence_Of (P, Loc),
4967 Attribute_Name => Name_Address);
4968
4969 Append (Pdecl, Decls);
4970 end if;
4971
4972 -- Now we can create the call, case of protected type
4973
4974 if Is_Protected_Type (Conctyp) then
4975 case Corresponding_Runtime_Package (Conctyp) is
4976 when System_Tasking_Protected_Objects_Entries =>
4977
4978 -- Change the type of the index declaration
4979
4980 Set_Object_Definition (Xdecl,
4981 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc));
4982
4983 -- Some additional declarations for protected entry calls
4984
4985 if No (Decls) then
4986 Decls := New_List;
4987 end if;
4988
4989 -- Bnn : Communications_Block;
4990
4991 Comm_Name := Make_Temporary (Loc, 'B');
4992
4993 Append_To (Decls,
4994 Make_Object_Declaration (Loc,
4995 Defining_Identifier => Comm_Name,
4996 Object_Definition =>
4997 New_Occurrence_Of
4998 (RTE (RE_Communication_Block), Loc)));
4999
5000 -- Some additional statements for protected entry calls
5001
5002 -- Protected_Entry_Call (
5003 -- Object => po._object'Access,
5004 -- E => <entry index>;
5005 -- Uninterpreted_Data => P'Address;
5006 -- Mode => Simple_Call;
5007 -- Block => Bnn);
5008
5009 Call :=
5010 Make_Procedure_Call_Statement (Loc,
5011 Name =>
5012 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc),
5013
5014 Parameter_Associations => New_List (
5015 Make_Attribute_Reference (Loc,
5016 Attribute_Name => Name_Unchecked_Access,
5017 Prefix => Parm1),
5018 Parm2,
5019 Parm3,
5020 New_Occurrence_Of (RTE (RE_Simple_Call), Loc),
5021 New_Occurrence_Of (Comm_Name, Loc)));
5022
5023 when System_Tasking_Protected_Objects_Single_Entry =>
5024 -- Protected_Single_Entry_Call (
5025 -- Object => po._object'Access,
5026 -- Uninterpreted_Data => P'Address);
5027
5028 Call :=
5029 Make_Procedure_Call_Statement (Loc,
5030 Name =>
5031 New_Occurrence_Of
5032 (RTE (RE_Protected_Single_Entry_Call), Loc),
5033
5034 Parameter_Associations => New_List (
5035 Make_Attribute_Reference (Loc,
5036 Attribute_Name => Name_Unchecked_Access,
5037 Prefix => Parm1),
5038 Parm3));
5039
5040 when others =>
5041 raise Program_Error;
5042 end case;
5043
5044 -- Case of task type
5045
5046 else
5047 Call :=
5048 Make_Procedure_Call_Statement (Loc,
5049 Name =>
5050 New_Occurrence_Of (RTE (RE_Call_Simple), Loc),
5051 Parameter_Associations => New_List (Parm1, Parm2, Parm3));
5052
5053 end if;
5054
5055 Append_To (Stats, Call);
5056
5057 -- If there are out or in/out parameters by copy add assignment
5058 -- statements for the result values.
5059
5060 if Present (Parms) then
5061 Actual := First_Actual (N);
5062 Formal := First_Formal (Ent);
5063
5064 Set_Assignment_OK (Actual);
5065 while Present (Actual) loop
5066 if Is_By_Copy_Type (Etype (Actual))
5067 and then Ekind (Formal) /= E_In_Parameter
5068 then
5069 N_Node :=
5070 Make_Assignment_Statement (Loc,
5071 Name => New_Copy (Actual),
5072 Expression =>
5073 Make_Explicit_Dereference (Loc,
5074 Make_Selected_Component (Loc,
5075 Prefix => New_Occurrence_Of (P, Loc),
5076 Selector_Name =>
5077 Make_Identifier (Loc, Chars (Formal)))));
5078
5079 -- In all cases (including limited private types) we want
5080 -- the assignment to be valid.
5081
5082 Set_Assignment_OK (Name (N_Node));
5083
5084 -- If the call is the triggering alternative in an
5085 -- asynchronous select, or the entry_call alternative of a
5086 -- conditional entry call, the assignments for in-out
5087 -- parameters are incorporated into the statement list that
5088 -- follows, so that there are executed only if the entry
5089 -- call succeeds.
5090
5091 if (Nkind (Parent (N)) = N_Triggering_Alternative
5092 and then N = Triggering_Statement (Parent (N)))
5093 or else
5094 (Nkind (Parent (N)) = N_Entry_Call_Alternative
5095 and then N = Entry_Call_Statement (Parent (N)))
5096 then
5097 if No (Statements (Parent (N))) then
5098 Set_Statements (Parent (N), New_List);
5099 end if;
5100
5101 Prepend (N_Node, Statements (Parent (N)));
5102
5103 else
5104 Insert_After (Call, N_Node);
5105 end if;
5106 end if;
5107
5108 Next_Actual (Actual);
5109 Next_Formal_With_Extras (Formal);
5110 end loop;
5111 end if;
5112
5113 -- Finally, create block and analyze it
5114
5115 Rewrite (N,
5116 Make_Block_Statement (Loc,
5117 Declarations => Decls,
5118 Handled_Statement_Sequence =>
5119 Make_Handled_Sequence_Of_Statements (Loc,
5120 Statements => Stats)));
5121
5122 Analyze (N);
5123 end;
5124 end Build_Simple_Entry_Call;
5125
5126 --------------------------------
5127 -- Build_Task_Activation_Call --
5128 --------------------------------
5129
5130 procedure Build_Task_Activation_Call (N : Node_Id) is
5131 Loc : constant Source_Ptr := Sloc (N);
5132 Chain : Entity_Id;
5133 Call : Node_Id;
5134 Name : Node_Id;
5135 P : Node_Id;
5136
5137 begin
5138 -- For sequential elaboration policy, all the tasks will be activated at
5139 -- the end of the elaboration.
5140
5141 if Partition_Elaboration_Policy = 'S' then
5142 return;
5143 end if;
5144
5145 -- Get the activation chain entity. Except in the case of a package
5146 -- body, this is in the node that was passed. For a package body, we
5147 -- have to find the corresponding package declaration node.
5148
5149 if Nkind (N) = N_Package_Body then
5150 P := Corresponding_Spec (N);
5151 loop
5152 P := Parent (P);
5153 exit when Nkind (P) = N_Package_Declaration;
5154 end loop;
5155
5156 Chain := Activation_Chain_Entity (P);
5157
5158 else
5159 Chain := Activation_Chain_Entity (N);
5160 end if;
5161
5162 if Present (Chain) then
5163 if Restricted_Profile then
5164 Name := New_Occurrence_Of
5165 (RTE (RE_Activate_Restricted_Tasks), Loc);
5166 else
5167 Name := New_Occurrence_Of
5168 (RTE (RE_Activate_Tasks), Loc);
5169 end if;
5170
5171 Call :=
5172 Make_Procedure_Call_Statement (Loc,
5173 Name => Name,
5174 Parameter_Associations =>
5175 New_List (Make_Attribute_Reference (Loc,
5176 Prefix => New_Occurrence_Of (Chain, Loc),
5177 Attribute_Name => Name_Unchecked_Access)));
5178
5179 if Nkind (N) = N_Package_Declaration then
5180 if Present (Corresponding_Body (N)) then
5181 null;
5182
5183 elsif Present (Private_Declarations (Specification (N))) then
5184 Append (Call, Private_Declarations (Specification (N)));
5185
5186 else
5187 Append (Call, Visible_Declarations (Specification (N)));
5188 end if;
5189
5190 else
5191 if Present (Handled_Statement_Sequence (N)) then
5192
5193 -- The call goes at the start of the statement sequence after
5194 -- the start of exception range label if one is present.
5195
5196 declare
5197 Stm : Node_Id;
5198
5199 begin
5200 Stm := First (Statements (Handled_Statement_Sequence (N)));
5201
5202 -- A special case, skip exception range label if one is
5203 -- present (from front end zcx processing).
5204
5205 if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then
5206 Next (Stm);
5207 end if;
5208
5209 -- Another special case, if the first statement is a block
5210 -- from optimization of a local raise to a goto, then the
5211 -- call goes inside this block.
5212
5213 if Nkind (Stm) = N_Block_Statement
5214 and then Exception_Junk (Stm)
5215 then
5216 Stm :=
5217 First (Statements (Handled_Statement_Sequence (Stm)));
5218 end if;
5219
5220 -- Insertion point is after any exception label pushes,
5221 -- since we want it covered by any local handlers.
5222
5223 while Nkind (Stm) in N_Push_xxx_Label loop
5224 Next (Stm);
5225 end loop;
5226
5227 -- Now we have the proper insertion point
5228
5229 Insert_Before (Stm, Call);
5230 end;
5231
5232 else
5233 Set_Handled_Statement_Sequence (N,
5234 Make_Handled_Sequence_Of_Statements (Loc,
5235 Statements => New_List (Call)));
5236 end if;
5237 end if;
5238
5239 Analyze (Call);
5240 Check_Task_Activation (N);
5241 end if;
5242 end Build_Task_Activation_Call;
5243
5244 -------------------------------
5245 -- Build_Task_Allocate_Block --
5246 -------------------------------
5247
5248 procedure Build_Task_Allocate_Block
5249 (Actions : List_Id;
5250 N : Node_Id;
5251 Args : List_Id)
5252 is
5253 T : constant Entity_Id := Entity (Expression (N));
5254 Init : constant Entity_Id := Base_Init_Proc (T);
5255 Loc : constant Source_Ptr := Sloc (N);
5256 Chain : constant Entity_Id :=
5257 Make_Defining_Identifier (Loc, Name_uChain);
5258 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
5259 Block : Node_Id;
5260
5261 begin
5262 Block :=
5263 Make_Block_Statement (Loc,
5264 Identifier => New_Occurrence_Of (Blkent, Loc),
5265 Declarations => New_List (
5266
5267 -- _Chain : Activation_Chain;
5268
5269 Make_Object_Declaration (Loc,
5270 Defining_Identifier => Chain,
5271 Aliased_Present => True,
5272 Object_Definition =>
5273 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))),
5274
5275 Handled_Statement_Sequence =>
5276 Make_Handled_Sequence_Of_Statements (Loc,
5277
5278 Statements => New_List (
5279
5280 -- Init (Args);
5281
5282 Make_Procedure_Call_Statement (Loc,
5283 Name => New_Occurrence_Of (Init, Loc),
5284 Parameter_Associations => Args),
5285
5286 -- Activate_Tasks (_Chain);
5287
5288 Make_Procedure_Call_Statement (Loc,
5289 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc),
5290 Parameter_Associations => New_List (
5291 Make_Attribute_Reference (Loc,
5292 Prefix => New_Occurrence_Of (Chain, Loc),
5293 Attribute_Name => Name_Unchecked_Access))))),
5294
5295 Has_Created_Identifier => True,
5296 Is_Task_Allocation_Block => True);
5297
5298 Append_To (Actions,
5299 Make_Implicit_Label_Declaration (Loc,
5300 Defining_Identifier => Blkent,
5301 Label_Construct => Block));
5302
5303 Append_To (Actions, Block);
5304
5305 Set_Activation_Chain_Entity (Block, Chain);
5306 end Build_Task_Allocate_Block;
5307
5308 -----------------------------------------------
5309 -- Build_Task_Allocate_Block_With_Init_Stmts --
5310 -----------------------------------------------
5311
5312 procedure Build_Task_Allocate_Block_With_Init_Stmts
5313 (Actions : List_Id;
5314 N : Node_Id;
5315 Init_Stmts : List_Id)
5316 is
5317 Loc : constant Source_Ptr := Sloc (N);
5318 Chain : constant Entity_Id :=
5319 Make_Defining_Identifier (Loc, Name_uChain);
5320 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
5321 Block : Node_Id;
5322
5323 begin
5324 Append_To (Init_Stmts,
5325 Make_Procedure_Call_Statement (Loc,
5326 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc),
5327 Parameter_Associations => New_List (
5328 Make_Attribute_Reference (Loc,
5329 Prefix => New_Occurrence_Of (Chain, Loc),
5330 Attribute_Name => Name_Unchecked_Access))));
5331
5332 Block :=
5333 Make_Block_Statement (Loc,
5334 Identifier => New_Occurrence_Of (Blkent, Loc),
5335 Declarations => New_List (
5336
5337 -- _Chain : Activation_Chain;
5338
5339 Make_Object_Declaration (Loc,
5340 Defining_Identifier => Chain,
5341 Aliased_Present => True,
5342 Object_Definition =>
5343 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))),
5344
5345 Handled_Statement_Sequence =>
5346 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts),
5347
5348 Has_Created_Identifier => True,
5349 Is_Task_Allocation_Block => True);
5350
5351 Append_To (Actions,
5352 Make_Implicit_Label_Declaration (Loc,
5353 Defining_Identifier => Blkent,
5354 Label_Construct => Block));
5355
5356 Append_To (Actions, Block);
5357
5358 Set_Activation_Chain_Entity (Block, Chain);
5359 end Build_Task_Allocate_Block_With_Init_Stmts;
5360
5361 -----------------------------------
5362 -- Build_Task_Proc_Specification --
5363 -----------------------------------
5364
5365 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is
5366 Loc : constant Source_Ptr := Sloc (T);
5367 Spec_Id : Entity_Id;
5368
5369 begin
5370 -- Case of explicit task type, suffix TB
5371
5372 if Comes_From_Source (T) then
5373 Spec_Id :=
5374 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB"));
5375
5376 -- Case of anonymous task type, suffix B
5377
5378 else
5379 Spec_Id :=
5380 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B'));
5381 end if;
5382
5383 Set_Is_Internal (Spec_Id);
5384
5385 -- Associate the procedure with the task, if this is the declaration
5386 -- (and not the body) of the procedure.
5387
5388 if No (Task_Body_Procedure (T)) then
5389 Set_Task_Body_Procedure (T, Spec_Id);
5390 end if;
5391
5392 return
5393 Make_Procedure_Specification (Loc,
5394 Defining_Unit_Name => Spec_Id,
5395 Parameter_Specifications => New_List (
5396 Make_Parameter_Specification (Loc,
5397 Defining_Identifier =>
5398 Make_Defining_Identifier (Loc, Name_uTask),
5399 Parameter_Type =>
5400 Make_Access_Definition (Loc,
5401 Subtype_Mark =>
5402 New_Occurrence_Of (Corresponding_Record_Type (T), Loc)))));
5403 end Build_Task_Proc_Specification;
5404
5405 ---------------------------------------
5406 -- Build_Unprotected_Subprogram_Body --
5407 ---------------------------------------
5408
5409 function Build_Unprotected_Subprogram_Body
5410 (N : Node_Id;
5411 Pid : Node_Id) return Node_Id
5412 is
5413 Decls : constant List_Id := Declarations (N);
5414
5415 begin
5416 -- Add renamings for the Protection object, discriminals, privals, and
5417 -- the entry index constant for use by debugger.
5418
5419 Debug_Private_Data_Declarations (Decls);
5420
5421 -- Make an unprotected version of the subprogram for use within the same
5422 -- object, with a new name and an additional parameter representing the
5423 -- object.
5424
5425 return
5426 Make_Subprogram_Body (Sloc (N),
5427 Specification =>
5428 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode),
5429 Declarations => Decls,
5430 Handled_Statement_Sequence => Handled_Statement_Sequence (N));
5431 end Build_Unprotected_Subprogram_Body;
5432
5433 ----------------------------
5434 -- Collect_Entry_Families --
5435 ----------------------------
5436
5437 procedure Collect_Entry_Families
5438 (Loc : Source_Ptr;
5439 Cdecls : List_Id;
5440 Current_Node : in out Node_Id;
5441 Conctyp : Entity_Id)
5442 is
5443 Efam : Entity_Id;
5444 Efam_Decl : Node_Id;
5445 Efam_Type : Entity_Id;
5446
5447 begin
5448 Efam := First_Entity (Conctyp);
5449 while Present (Efam) loop
5450 if Ekind (Efam) = E_Entry_Family then
5451 Efam_Type := Make_Temporary (Loc, 'F');
5452
5453 declare
5454 Bas : Entity_Id :=
5455 Base_Type
5456 (Etype (Discrete_Subtype_Definition (Parent (Efam))));
5457
5458 Bas_Decl : Node_Id := Empty;
5459 Lo, Hi : Node_Id;
5460
5461 begin
5462 Get_Index_Bounds
5463 (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi);
5464
5465 if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then
5466 Bas := Make_Temporary (Loc, 'B');
5467
5468 Bas_Decl :=
5469 Make_Subtype_Declaration (Loc,
5470 Defining_Identifier => Bas,
5471 Subtype_Indication =>
5472 Make_Subtype_Indication (Loc,
5473 Subtype_Mark =>
5474 New_Occurrence_Of (Standard_Integer, Loc),
5475 Constraint =>
5476 Make_Range_Constraint (Loc,
5477 Range_Expression => Make_Range (Loc,
5478 Make_Integer_Literal
5479 (Loc, -Entry_Family_Bound),
5480 Make_Integer_Literal
5481 (Loc, Entry_Family_Bound - 1)))));
5482
5483 Insert_After (Current_Node, Bas_Decl);
5484 Current_Node := Bas_Decl;
5485 Analyze (Bas_Decl);
5486 end if;
5487
5488 Efam_Decl :=
5489 Make_Full_Type_Declaration (Loc,
5490 Defining_Identifier => Efam_Type,
5491 Type_Definition =>
5492 Make_Unconstrained_Array_Definition (Loc,
5493 Subtype_Marks =>
5494 (New_List (New_Occurrence_Of (Bas, Loc))),
5495
5496 Component_Definition =>
5497 Make_Component_Definition (Loc,
5498 Aliased_Present => False,
5499 Subtype_Indication =>
5500 New_Occurrence_Of (Standard_Character, Loc))));
5501 end;
5502
5503 Insert_After (Current_Node, Efam_Decl);
5504 Current_Node := Efam_Decl;
5505 Analyze (Efam_Decl);
5506
5507 Append_To (Cdecls,
5508 Make_Component_Declaration (Loc,
5509 Defining_Identifier =>
5510 Make_Defining_Identifier (Loc, Chars (Efam)),
5511
5512 Component_Definition =>
5513 Make_Component_Definition (Loc,
5514 Aliased_Present => False,
5515 Subtype_Indication =>
5516 Make_Subtype_Indication (Loc,
5517 Subtype_Mark =>
5518 New_Occurrence_Of (Efam_Type, Loc),
5519
5520 Constraint =>
5521 Make_Index_Or_Discriminant_Constraint (Loc,
5522 Constraints => New_List (
5523 New_Occurrence_Of
5524 (Etype (Discrete_Subtype_Definition
5525 (Parent (Efam))), Loc)))))));
5526
5527 end if;
5528
5529 Next_Entity (Efam);
5530 end loop;
5531 end Collect_Entry_Families;
5532
5533 -----------------------
5534 -- Concurrent_Object --
5535 -----------------------
5536
5537 function Concurrent_Object
5538 (Spec_Id : Entity_Id;
5539 Conc_Typ : Entity_Id) return Entity_Id
5540 is
5541 begin
5542 -- Parameter _O or _object
5543
5544 if Is_Protected_Type (Conc_Typ) then
5545 return First_Formal (Protected_Body_Subprogram (Spec_Id));
5546
5547 -- Parameter _task
5548
5549 else
5550 pragma Assert (Is_Task_Type (Conc_Typ));
5551 return First_Formal (Task_Body_Procedure (Conc_Typ));
5552 end if;
5553 end Concurrent_Object;
5554
5555 ----------------------
5556 -- Copy_Result_Type --
5557 ----------------------
5558
5559 function Copy_Result_Type (Res : Node_Id) return Node_Id is
5560 New_Res : constant Node_Id := New_Copy_Tree (Res);
5561 Par_Spec : Node_Id;
5562 Formal : Entity_Id;
5563
5564 begin
5565 -- If the result type is an access_to_subprogram, we must create new
5566 -- entities for its spec.
5567
5568 if Nkind (New_Res) = N_Access_Definition
5569 and then Present (Access_To_Subprogram_Definition (New_Res))
5570 then
5571 -- Provide new entities for the formals
5572
5573 Par_Spec := First (Parameter_Specifications
5574 (Access_To_Subprogram_Definition (New_Res)));
5575 while Present (Par_Spec) loop
5576 Formal := Defining_Identifier (Par_Spec);
5577 Set_Defining_Identifier (Par_Spec,
5578 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)));
5579 Next (Par_Spec);
5580 end loop;
5581 end if;
5582
5583 return New_Res;
5584 end Copy_Result_Type;
5585
5586 --------------------
5587 -- Concurrent_Ref --
5588 --------------------
5589
5590 -- The expression returned for a reference to a concurrent object has the
5591 -- form:
5592
5593 -- taskV!(name)._Task_Id
5594
5595 -- for a task, and
5596
5597 -- objectV!(name)._Object
5598
5599 -- for a protected object. For the case of an access to a concurrent
5600 -- object, there is an extra explicit dereference:
5601
5602 -- taskV!(name.all)._Task_Id
5603 -- objectV!(name.all)._Object
5604
5605 -- here taskV and objectV are the types for the associated records, which
5606 -- contain the required _Task_Id and _Object fields for tasks and protected
5607 -- objects, respectively.
5608
5609 -- For the case of a task type name, the expression is
5610
5611 -- Self;
5612
5613 -- i.e. a call to the Self function which returns precisely this Task_Id
5614
5615 -- For the case of a protected type name, the expression is
5616
5617 -- objectR
5618
5619 -- which is a renaming of the _object field of the current object
5620 -- record, passed into protected operations as a parameter.
5621
5622 function Concurrent_Ref (N : Node_Id) return Node_Id is
5623 Loc : constant Source_Ptr := Sloc (N);
5624 Ntyp : constant Entity_Id := Etype (N);
5625 Dtyp : Entity_Id;
5626 Sel : Name_Id;
5627
5628 function Is_Current_Task (T : Entity_Id) return Boolean;
5629 -- Check whether the reference is to the immediately enclosing task
5630 -- type, or to an outer one (rare but legal).
5631
5632 ---------------------
5633 -- Is_Current_Task --
5634 ---------------------
5635
5636 function Is_Current_Task (T : Entity_Id) return Boolean is
5637 Scop : Entity_Id;
5638
5639 begin
5640 Scop := Current_Scope;
5641 while Present (Scop) and then Scop /= Standard_Standard loop
5642 if Scop = T then
5643 return True;
5644
5645 elsif Is_Task_Type (Scop) then
5646 return False;
5647
5648 -- If this is a procedure nested within the task type, we must
5649 -- assume that it can be called from an inner task, and therefore
5650 -- cannot treat it as a local reference.
5651
5652 elsif Is_Overloadable (Scop) and then In_Open_Scopes (T) then
5653 return False;
5654
5655 else
5656 Scop := Scope (Scop);
5657 end if;
5658 end loop;
5659
5660 -- We know that we are within the task body, so should have found it
5661 -- in scope.
5662
5663 raise Program_Error;
5664 end Is_Current_Task;
5665
5666 -- Start of processing for Concurrent_Ref
5667
5668 begin
5669 if Is_Access_Type (Ntyp) then
5670 Dtyp := Designated_Type (Ntyp);
5671
5672 if Is_Protected_Type (Dtyp) then
5673 Sel := Name_uObject;
5674 else
5675 Sel := Name_uTask_Id;
5676 end if;
5677
5678 return
5679 Make_Selected_Component (Loc,
5680 Prefix =>
5681 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp),
5682 Make_Explicit_Dereference (Loc, N)),
5683 Selector_Name => Make_Identifier (Loc, Sel));
5684
5685 elsif Is_Entity_Name (N) and then Is_Concurrent_Type (Entity (N)) then
5686 if Is_Task_Type (Entity (N)) then
5687
5688 if Is_Current_Task (Entity (N)) then
5689 return
5690 Make_Function_Call (Loc,
5691 Name => New_Occurrence_Of (RTE (RE_Self), Loc));
5692
5693 else
5694 declare
5695 Decl : Node_Id;
5696 T_Self : constant Entity_Id := Make_Temporary (Loc, 'T');
5697 T_Body : constant Node_Id :=
5698 Parent (Corresponding_Body (Parent (Entity (N))));
5699
5700 begin
5701 Decl :=
5702 Make_Object_Declaration (Loc,
5703 Defining_Identifier => T_Self,
5704 Object_Definition =>
5705 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
5706 Expression =>
5707 Make_Function_Call (Loc,
5708 Name => New_Occurrence_Of (RTE (RE_Self), Loc)));
5709 Prepend (Decl, Declarations (T_Body));
5710 Analyze (Decl);
5711 Set_Scope (T_Self, Entity (N));
5712 return New_Occurrence_Of (T_Self, Loc);
5713 end;
5714 end if;
5715
5716 else
5717 pragma Assert (Is_Protected_Type (Entity (N)));
5718
5719 return
5720 New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc);
5721 end if;
5722
5723 else
5724 if Is_Protected_Type (Ntyp) then
5725 Sel := Name_uObject;
5726 elsif Is_Task_Type (Ntyp) then
5727 Sel := Name_uTask_Id;
5728 else
5729 raise Program_Error;
5730 end if;
5731
5732 return
5733 Make_Selected_Component (Loc,
5734 Prefix =>
5735 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp),
5736 New_Copy_Tree (N)),
5737 Selector_Name => Make_Identifier (Loc, Sel));
5738 end if;
5739 end Concurrent_Ref;
5740
5741 ------------------------
5742 -- Convert_Concurrent --
5743 ------------------------
5744
5745 function Convert_Concurrent
5746 (N : Node_Id;
5747 Typ : Entity_Id) return Node_Id
5748 is
5749 begin
5750 if not Is_Concurrent_Type (Typ) then
5751 return N;
5752 else
5753 return
5754 Unchecked_Convert_To
5755 (Corresponding_Record_Type (Typ), New_Copy_Tree (N));
5756 end if;
5757 end Convert_Concurrent;
5758
5759 -------------------------------------
5760 -- Debug_Private_Data_Declarations --
5761 -------------------------------------
5762
5763 procedure Debug_Private_Data_Declarations (Decls : List_Id) is
5764 Debug_Nod : Node_Id;
5765 Decl : Node_Id;
5766
5767 begin
5768 Decl := First (Decls);
5769 while Present (Decl) and then not Comes_From_Source (Decl) loop
5770
5771 -- Declaration for concurrent entity _object and its access type,
5772 -- along with the entry index subtype:
5773 -- type prot_typVP is access prot_typV;
5774 -- _object : prot_typVP := prot_typV (_O);
5775 -- subtype Jnn is <Type of Index> range Low .. High;
5776
5777 if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then
5778 Set_Debug_Info_Needed (Defining_Identifier (Decl));
5779
5780 -- Declaration for the Protection object, discriminals, privals, and
5781 -- entry index constant:
5782 -- conc_typR : protection_typ renames _object._object;
5783 -- discr_nameD : discr_typ renames _object.discr_name;
5784 -- discr_nameD : discr_typ renames _task.discr_name;
5785 -- prival_name : comp_typ renames _object.comp_name;
5786 -- J : constant Jnn :=
5787 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
5788
5789 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
5790 Set_Debug_Info_Needed (Defining_Identifier (Decl));
5791 Debug_Nod := Debug_Renaming_Declaration (Decl);
5792
5793 if Present (Debug_Nod) then
5794 Insert_After (Decl, Debug_Nod);
5795 end if;
5796 end if;
5797
5798 Next (Decl);
5799 end loop;
5800 end Debug_Private_Data_Declarations;
5801
5802 ------------------------------
5803 -- Ensure_Statement_Present --
5804 ------------------------------
5805
5806 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is
5807 Stmt : Node_Id;
5808
5809 begin
5810 if Opt.Suppress_Control_Flow_Optimizations
5811 and then Is_Empty_List (Statements (Alt))
5812 then
5813 Stmt := Make_Null_Statement (Loc);
5814
5815 -- Mark NULL statement as coming from source so that it is not
5816 -- eliminated by GIGI.
5817
5818 -- Another covert channel. If this is a requirement, it must be
5819 -- documented in sinfo/einfo ???
5820
5821 Set_Comes_From_Source (Stmt, True);
5822
5823 Set_Statements (Alt, New_List (Stmt));
5824 end if;
5825 end Ensure_Statement_Present;
5826
5827 ----------------------------
5828 -- Entry_Index_Expression --
5829 ----------------------------
5830
5831 function Entry_Index_Expression
5832 (Sloc : Source_Ptr;
5833 Ent : Entity_Id;
5834 Index : Node_Id;
5835 Ttyp : Entity_Id) return Node_Id
5836 is
5837 Expr : Node_Id;
5838 Num : Node_Id;
5839 Lo : Node_Id;
5840 Hi : Node_Id;
5841 Prev : Entity_Id;
5842 S : Node_Id;
5843
5844 begin
5845 -- The queues of entries and entry families appear in textual order in
5846 -- the associated record. The entry index is computed as the sum of the
5847 -- number of queues for all entries that precede the designated one, to
5848 -- which is added the index expression, if this expression denotes a
5849 -- member of a family.
5850
5851 -- The following is a place holder for the count of simple entries
5852
5853 Num := Make_Integer_Literal (Sloc, 1);
5854
5855 -- We construct an expression which is a series of addition operations.
5856 -- The first operand is the number of single entries that precede this
5857 -- one, the second operand is the index value relative to the start of
5858 -- the referenced family, and the remaining operands are the lengths of
5859 -- the entry families that precede this entry, i.e. the constructed
5860 -- expression is:
5861
5862 -- number_simple_entries +
5863 -- (s'pos (index-value) - s'pos (family'first)) + 1 +
5864 -- family'length + ...
5865
5866 -- where index-value is the given index value, and s is the index
5867 -- subtype (we have to use pos because the subtype might be an
5868 -- enumeration type preventing direct subtraction). Note that the task
5869 -- entry array is one-indexed.
5870
5871 -- The upper bound of the entry family may be a discriminant, so we
5872 -- retrieve the lower bound explicitly to compute offset, rather than
5873 -- using the index subtype which may mention a discriminant.
5874
5875 if Present (Index) then
5876 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent)));
5877
5878 Expr :=
5879 Make_Op_Add (Sloc,
5880 Left_Opnd => Num,
5881 Right_Opnd =>
5882 Family_Offset
5883 (Sloc,
5884 Make_Attribute_Reference (Sloc,
5885 Attribute_Name => Name_Pos,
5886 Prefix => New_Occurrence_Of (Base_Type (S), Sloc),
5887 Expressions => New_List (Relocate_Node (Index))),
5888 Type_Low_Bound (S),
5889 Ttyp,
5890 False));
5891 else
5892 Expr := Num;
5893 end if;
5894
5895 -- Now add lengths of preceding entries and entry families
5896
5897 Prev := First_Entity (Ttyp);
5898 while Chars (Prev) /= Chars (Ent)
5899 or else (Ekind (Prev) /= Ekind (Ent))
5900 or else not Sem_Ch6.Type_Conformant (Ent, Prev)
5901 loop
5902 if Ekind (Prev) = E_Entry then
5903 Set_Intval (Num, Intval (Num) + 1);
5904
5905 elsif Ekind (Prev) = E_Entry_Family then
5906 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Prev)));
5907 Lo := Type_Low_Bound (S);
5908 Hi := Type_High_Bound (S);
5909
5910 Expr :=
5911 Make_Op_Add (Sloc,
5912 Left_Opnd => Expr,
5913 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False));
5914
5915 -- Other components are anonymous types to be ignored
5916
5917 else
5918 null;
5919 end if;
5920
5921 Next_Entity (Prev);
5922 end loop;
5923
5924 return Expr;
5925 end Entry_Index_Expression;
5926
5927 ---------------------------
5928 -- Establish_Task_Master --
5929 ---------------------------
5930
5931 procedure Establish_Task_Master (N : Node_Id) is
5932 Call : Node_Id;
5933
5934 begin
5935 if Restriction_Active (No_Task_Hierarchy) = False then
5936 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
5937
5938 -- The block may have no declarations (and nevertheless be a task
5939 -- master) if it contains a call that may return an object that
5940 -- contains tasks.
5941
5942 if No (Declarations (N)) then
5943 Set_Declarations (N, New_List (Call));
5944 else
5945 Prepend_To (Declarations (N), Call);
5946 end if;
5947
5948 Analyze (Call);
5949 end if;
5950 end Establish_Task_Master;
5951
5952 --------------------------------
5953 -- Expand_Accept_Declarations --
5954 --------------------------------
5955
5956 -- Part of the expansion of an accept statement involves the creation of
5957 -- a declaration that can be referenced from the statement sequence of
5958 -- the accept:
5959
5960 -- Ann : Address;
5961
5962 -- This declaration is inserted immediately before the accept statement
5963 -- and it is important that it be inserted before the statements of the
5964 -- statement sequence are analyzed. Thus it would be too late to create
5965 -- this declaration in the Expand_N_Accept_Statement routine, which is
5966 -- why there is a separate procedure to be called directly from Sem_Ch9.
5967
5968 -- Ann is used to hold the address of the record containing the parameters
5969 -- (see Expand_N_Entry_Call for more details on how this record is built).
5970 -- References to the parameters do an unchecked conversion of this address
5971 -- to a pointer to the required record type, and then access the field that
5972 -- holds the value of the required parameter. The entity for the address
5973 -- variable is held as the top stack element (i.e. the last element) of the
5974 -- Accept_Address stack in the corresponding entry entity, and this element
5975 -- must be set in place before the statements are processed.
5976
5977 -- The above description applies to the case of a stand alone accept
5978 -- statement, i.e. one not appearing as part of a select alternative.
5979
5980 -- For the case of an accept that appears as part of a select alternative
5981 -- of a selective accept, we must still create the declaration right away,
5982 -- since Ann is needed immediately, but there is an important difference:
5983
5984 -- The declaration is inserted before the selective accept, not before
5985 -- the accept statement (which is not part of a list anyway, and so would
5986 -- not accommodate inserted declarations)
5987
5988 -- We only need one address variable for the entire selective accept. So
5989 -- the Ann declaration is created only for the first accept alternative,
5990 -- and subsequent accept alternatives reference the same Ann variable.
5991
5992 -- We can distinguish the two cases by seeing whether the accept statement
5993 -- is part of a list. If not, then it must be in an accept alternative.
5994
5995 -- To expand the requeue statement, a label is provided at the end of the
5996 -- accept statement or alternative of which it is a part, so that the
5997 -- statement can be skipped after the requeue is complete. This label is
5998 -- created here rather than during the expansion of the accept statement,
5999 -- because it will be needed by any requeue statements within the accept,
6000 -- which are expanded before the accept.
6001
6002 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is
6003 Loc : constant Source_Ptr := Sloc (N);
6004 Stats : constant Node_Id := Handled_Statement_Sequence (N);
6005 Ann : Entity_Id := Empty;
6006 Adecl : Node_Id;
6007 Lab : Node_Id;
6008 Ldecl : Node_Id;
6009 Ldecl2 : Node_Id;
6010
6011 begin
6012 if Expander_Active then
6013
6014 -- If we have no handled statement sequence, we may need to build
6015 -- a dummy sequence consisting of a null statement. This can be
6016 -- skipped if the trivial accept optimization is permitted.
6017
6018 if not Trivial_Accept_OK
6019 and then (No (Stats) or else Null_Statements (Statements (Stats)))
6020 then
6021 Set_Handled_Statement_Sequence (N,
6022 Make_Handled_Sequence_Of_Statements (Loc,
6023 Statements => New_List (Make_Null_Statement (Loc))));
6024 end if;
6025
6026 -- Create and declare two labels to be placed at the end of the
6027 -- accept statement. The first label is used to allow requeues to
6028 -- skip the remainder of entry processing. The second label is used
6029 -- to skip the remainder of entry processing if the rendezvous
6030 -- completes in the middle of the accept body.
6031
6032 if Present (Handled_Statement_Sequence (N)) then
6033 declare
6034 Ent : Entity_Id;
6035
6036 begin
6037 Ent := Make_Temporary (Loc, 'L');
6038 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc));
6039 Ldecl :=
6040 Make_Implicit_Label_Declaration (Loc,
6041 Defining_Identifier => Ent,
6042 Label_Construct => Lab);
6043 Append (Lab, Statements (Handled_Statement_Sequence (N)));
6044
6045 Ent := Make_Temporary (Loc, 'L');
6046 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc));
6047 Ldecl2 :=
6048 Make_Implicit_Label_Declaration (Loc,
6049 Defining_Identifier => Ent,
6050 Label_Construct => Lab);
6051 Append (Lab, Statements (Handled_Statement_Sequence (N)));
6052 end;
6053
6054 else
6055 Ldecl := Empty;
6056 Ldecl2 := Empty;
6057 end if;
6058
6059 -- Case of stand alone accept statement
6060
6061 if Is_List_Member (N) then
6062
6063 if Present (Handled_Statement_Sequence (N)) then
6064 Ann := Make_Temporary (Loc, 'A');
6065
6066 Adecl :=
6067 Make_Object_Declaration (Loc,
6068 Defining_Identifier => Ann,
6069 Object_Definition =>
6070 New_Occurrence_Of (RTE (RE_Address), Loc));
6071
6072 Insert_Before_And_Analyze (N, Adecl);
6073 Insert_Before_And_Analyze (N, Ldecl);
6074 Insert_Before_And_Analyze (N, Ldecl2);
6075 end if;
6076
6077 -- Case of accept statement which is in an accept alternative
6078
6079 else
6080 declare
6081 Acc_Alt : constant Node_Id := Parent (N);
6082 Sel_Acc : constant Node_Id := Parent (Acc_Alt);
6083 Alt : Node_Id;
6084
6085 begin
6086 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative);
6087 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept);
6088
6089 -- ??? Consider a single label for select statements
6090
6091 if Present (Handled_Statement_Sequence (N)) then
6092 Prepend (Ldecl2,
6093 Statements (Handled_Statement_Sequence (N)));
6094 Analyze (Ldecl2);
6095
6096 Prepend (Ldecl,
6097 Statements (Handled_Statement_Sequence (N)));
6098 Analyze (Ldecl);
6099 end if;
6100
6101 -- Find first accept alternative of the selective accept. A
6102 -- valid selective accept must have at least one accept in it.
6103
6104 Alt := First (Select_Alternatives (Sel_Acc));
6105
6106 while Nkind (Alt) /= N_Accept_Alternative loop
6107 Next (Alt);
6108 end loop;
6109
6110 -- If this is the first accept statement, then we have to
6111 -- create the Ann variable, as for the stand alone case, except
6112 -- that it is inserted before the selective accept. Similarly,
6113 -- a label for requeue expansion must be declared.
6114
6115 if N = Accept_Statement (Alt) then
6116 Ann := Make_Temporary (Loc, 'A');
6117 Adecl :=
6118 Make_Object_Declaration (Loc,
6119 Defining_Identifier => Ann,
6120 Object_Definition =>
6121 New_Occurrence_Of (RTE (RE_Address), Loc));
6122
6123 Insert_Before_And_Analyze (Sel_Acc, Adecl);
6124
6125 -- If this is not the first accept statement, then find the Ann
6126 -- variable allocated by the first accept and use it.
6127
6128 else
6129 Ann :=
6130 Node (Last_Elmt (Accept_Address
6131 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))));
6132 end if;
6133 end;
6134 end if;
6135
6136 -- Merge here with Ann either created or referenced, and Adecl
6137 -- pointing to the corresponding declaration. Remaining processing
6138 -- is the same for the two cases.
6139
6140 if Present (Ann) then
6141 Append_Elmt (Ann, Accept_Address (Ent));
6142 Set_Debug_Info_Needed (Ann);
6143 end if;
6144
6145 -- Create renaming declarations for the entry formals. Each reference
6146 -- to a formal becomes a dereference of a component of the parameter
6147 -- block, whose address is held in Ann. These declarations are
6148 -- eventually inserted into the accept block, and analyzed there so
6149 -- that they have the proper scope for gdb and do not conflict with
6150 -- other declarations.
6151
6152 if Present (Parameter_Specifications (N))
6153 and then Present (Handled_Statement_Sequence (N))
6154 then
6155 declare
6156 Comp : Entity_Id;
6157 Decl : Node_Id;
6158 Formal : Entity_Id;
6159 New_F : Entity_Id;
6160 Renamed_Formal : Node_Id;
6161
6162 begin
6163 Push_Scope (Ent);
6164 Formal := First_Formal (Ent);
6165
6166 while Present (Formal) loop
6167 Comp := Entry_Component (Formal);
6168 New_F := Make_Defining_Identifier (Loc, Chars (Formal));
6169
6170 Set_Etype (New_F, Etype (Formal));
6171 Set_Scope (New_F, Ent);
6172
6173 -- Now we set debug info needed on New_F even though it does
6174 -- not come from source, so that the debugger will get the
6175 -- right information for these generated names.
6176
6177 Set_Debug_Info_Needed (New_F);
6178
6179 if Ekind (Formal) = E_In_Parameter then
6180 Set_Ekind (New_F, E_Constant);
6181 else
6182 Set_Ekind (New_F, E_Variable);
6183 Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
6184 end if;
6185
6186 Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
6187
6188 Renamed_Formal :=
6189 Make_Selected_Component (Loc,
6190 Prefix =>
6191 Unchecked_Convert_To (
6192 Entry_Parameters_Type (Ent),
6193 New_Occurrence_Of (Ann, Loc)),
6194 Selector_Name =>
6195 New_Occurrence_Of (Comp, Loc));
6196
6197 Decl :=
6198 Build_Renamed_Formal_Declaration
6199 (New_F, Formal, Comp, Renamed_Formal);
6200
6201 if No (Declarations (N)) then
6202 Set_Declarations (N, New_List);
6203 end if;
6204
6205 Append (Decl, Declarations (N));
6206 Set_Renamed_Object (Formal, New_F);
6207 Next_Formal (Formal);
6208 end loop;
6209
6210 End_Scope;
6211 end;
6212 end if;
6213 end if;
6214 end Expand_Accept_Declarations;
6215
6216 ---------------------------------------------
6217 -- Expand_Access_Protected_Subprogram_Type --
6218 ---------------------------------------------
6219
6220 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is
6221 Loc : constant Source_Ptr := Sloc (N);
6222 Comps : List_Id;
6223 T : constant Entity_Id := Defining_Identifier (N);
6224 D_T : constant Entity_Id := Designated_Type (T);
6225 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D');
6226 E_T : constant Entity_Id := Make_Temporary (Loc, 'E');
6227 P_List : constant List_Id := Build_Protected_Spec
6228 (N, RTE (RE_Address), D_T, False);
6229 Decl1 : Node_Id;
6230 Decl2 : Node_Id;
6231 Def1 : Node_Id;
6232
6233 begin
6234 -- Create access to subprogram with full signature
6235
6236 if Etype (D_T) /= Standard_Void_Type then
6237 Def1 :=
6238 Make_Access_Function_Definition (Loc,
6239 Parameter_Specifications => P_List,
6240 Result_Definition =>
6241 Copy_Result_Type (Result_Definition (Type_Definition (N))));
6242
6243 else
6244 Def1 :=
6245 Make_Access_Procedure_Definition (Loc,
6246 Parameter_Specifications => P_List);
6247 end if;
6248
6249 Decl1 :=
6250 Make_Full_Type_Declaration (Loc,
6251 Defining_Identifier => D_T2,
6252 Type_Definition => Def1);
6253
6254 Insert_After_And_Analyze (N, Decl1);
6255
6256 -- Associate the access to subprogram with its original access to
6257 -- protected subprogram type. Needed by the backend to know that this
6258 -- type corresponds with an access to protected subprogram type.
6259
6260 Set_Original_Access_Type (D_T2, T);
6261
6262 -- Create Equivalent_Type, a record with two components for an access to
6263 -- object and an access to subprogram.
6264
6265 Comps := New_List (
6266 Make_Component_Declaration (Loc,
6267 Defining_Identifier => Make_Temporary (Loc, 'P'),
6268 Component_Definition =>
6269 Make_Component_Definition (Loc,
6270 Aliased_Present => False,
6271 Subtype_Indication =>
6272 New_Occurrence_Of (RTE (RE_Address), Loc))),
6273
6274 Make_Component_Declaration (Loc,
6275 Defining_Identifier => Make_Temporary (Loc, 'S'),
6276 Component_Definition =>
6277 Make_Component_Definition (Loc,
6278 Aliased_Present => False,
6279 Subtype_Indication => New_Occurrence_Of (D_T2, Loc))));
6280
6281 Decl2 :=
6282 Make_Full_Type_Declaration (Loc,
6283 Defining_Identifier => E_T,
6284 Type_Definition =>
6285 Make_Record_Definition (Loc,
6286 Component_List =>
6287 Make_Component_List (Loc, Component_Items => Comps)));
6288
6289 Insert_After_And_Analyze (Decl1, Decl2);
6290 Set_Equivalent_Type (T, E_T);
6291 end Expand_Access_Protected_Subprogram_Type;
6292
6293 --------------------------
6294 -- Expand_Entry_Barrier --
6295 --------------------------
6296
6297 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is
6298 Cond : constant Node_Id :=
6299 Condition (Entry_Body_Formal_Part (N));
6300 Prot : constant Entity_Id := Scope (Ent);
6301 Spec_Decl : constant Node_Id := Parent (Prot);
6302 Func : Entity_Id := Empty;
6303 B_F : Node_Id;
6304 Body_Decl : Node_Id;
6305
6306 function Is_Global_Entity (N : Node_Id) return Traverse_Result;
6307 -- Check whether entity in Barrier is external to protected type.
6308 -- If so, barrier may not be properly synchronized.
6309
6310 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result;
6311 -- Check whether N follows the Pure_Barriers restriction. Return OK if
6312 -- so.
6313
6314 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean;
6315 -- Check whether entity name N denotes a component of the protected
6316 -- object. This is used to check the Simple_Barrier restriction.
6317
6318 ----------------------
6319 -- Is_Global_Entity --
6320 ----------------------
6321
6322 function Is_Global_Entity (N : Node_Id) return Traverse_Result is
6323 E : Entity_Id;
6324 S : Entity_Id;
6325
6326 begin
6327 if Is_Entity_Name (N) and then Present (Entity (N)) then
6328 E := Entity (N);
6329 S := Scope (E);
6330
6331 if Ekind (E) = E_Variable then
6332
6333 -- If the variable is local to the barrier function generated
6334 -- during expansion, it is ok. If expansion is not performed,
6335 -- then Func is Empty so this test cannot succeed.
6336
6337 if Scope (E) = Func then
6338 null;
6339
6340 -- A protected call from a barrier to another object is ok
6341
6342 elsif Ekind (Etype (E)) = E_Protected_Type then
6343 null;
6344
6345 -- If the variable is within the package body we consider
6346 -- this safe. This is a common (if dubious) idiom.
6347
6348 elsif S = Scope (Prot)
6349 and then Ekind_In (S, E_Package, E_Generic_Package)
6350 and then Nkind (Parent (E)) = N_Object_Declaration
6351 and then Nkind (Parent (Parent (E))) = N_Package_Body
6352 then
6353 null;
6354
6355 else
6356 Error_Msg_N ("potentially unsynchronized barrier??", N);
6357 Error_Msg_N ("\& should be private component of type??", N);
6358 end if;
6359 end if;
6360 end if;
6361
6362 return OK;
6363 end Is_Global_Entity;
6364
6365 procedure Check_Unprotected_Barrier is
6366 new Traverse_Proc (Is_Global_Entity);
6367
6368 ----------------------------
6369 -- Is_Simple_Barrier_Name --
6370 ----------------------------
6371
6372 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is
6373 Renamed : Node_Id;
6374
6375 begin
6376 -- Check for case of _object.all.field (note that the explicit
6377 -- dereference gets inserted by analyze/expand of _object.field).
6378
6379 if Expander_Active then
6380 Renamed := Renamed_Object (Entity (N));
6381
6382 return
6383 Present (Renamed)
6384 and then Nkind (Renamed) = N_Selected_Component
6385 and then Chars (Prefix (Prefix (Renamed))) = Name_uObject;
6386 else
6387 return Scope (Entity (N)) = Current_Scope;
6388 end if;
6389 end Is_Simple_Barrier_Name;
6390
6391 ---------------------
6392 -- Is_Pure_Barrier --
6393 ---------------------
6394
6395 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is
6396 begin
6397 case Nkind (N) is
6398 when N_Expanded_Name |
6399 N_Identifier =>
6400 if No (Entity (N)) then
6401 return Abandon;
6402 end if;
6403
6404 case Ekind (Entity (N)) is
6405 when E_Constant |
6406 E_Discriminant |
6407 E_Named_Integer |
6408 E_Named_Real |
6409 E_Enumeration_Literal =>
6410 return OK;
6411
6412 when E_Component |
6413 E_Variable =>
6414
6415 -- A variable in the protected type is expanded as a
6416 -- component.
6417
6418 if Is_Simple_Barrier_Name (N) then
6419 return OK;
6420 end if;
6421
6422 when others =>
6423 null;
6424 end case;
6425
6426 when N_Integer_Literal |
6427 N_Real_Literal |
6428 N_Character_Literal =>
6429 return OK;
6430
6431 when N_Op_Boolean |
6432 N_Op_Not =>
6433 if Ekind (Entity (N)) = E_Operator then
6434 return OK;
6435 end if;
6436
6437 when N_Short_Circuit =>
6438 return OK;
6439
6440 when others =>
6441 null;
6442 end case;
6443
6444 return Abandon;
6445 end Is_Pure_Barrier;
6446
6447 function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier);
6448
6449 -- Start of processing for Expand_Entry_Barrier
6450
6451 begin
6452 if No_Run_Time_Mode then
6453 Error_Msg_CRT ("entry barrier", N);
6454 return;
6455 end if;
6456
6457 -- The body of the entry barrier must be analyzed in the context of the
6458 -- protected object, but its scope is external to it, just as any other
6459 -- unprotected version of a protected operation. The specification has
6460 -- been produced when the protected type declaration was elaborated. We
6461 -- build the body, insert it in the enclosing scope, but analyze it in
6462 -- the current context. A more uniform approach would be to treat the
6463 -- barrier just as a protected function, and discard the protected
6464 -- version of it because it is never called.
6465
6466 if Expander_Active then
6467 B_F := Build_Barrier_Function (N, Ent, Prot);
6468 Func := Barrier_Function (Ent);
6469 Set_Corresponding_Spec (B_F, Func);
6470
6471 Body_Decl := Parent (Corresponding_Body (Spec_Decl));
6472
6473 if Nkind (Parent (Body_Decl)) = N_Subunit then
6474 Body_Decl := Corresponding_Stub (Parent (Body_Decl));
6475 end if;
6476
6477 Insert_Before_And_Analyze (Body_Decl, B_F);
6478
6479 Set_Discriminals (Spec_Decl);
6480 Set_Scope (Func, Scope (Prot));
6481
6482 else
6483 Analyze_And_Resolve (Cond, Any_Boolean);
6484 end if;
6485
6486 -- Check Pure_Barriers restriction
6487
6488 if Check_Pure_Barriers (Cond) = Abandon then
6489 Check_Restriction (Pure_Barriers, Cond);
6490 end if;
6491
6492 -- The Ravenscar profile restricts barriers to simple variables declared
6493 -- within the protected object. We also allow Boolean constants, since
6494 -- these appear in several published examples and are also allowed by
6495 -- other compilers.
6496
6497 -- Note that after analysis variables in this context will be replaced
6498 -- by the corresponding prival, that is to say a renaming of a selected
6499 -- component of the form _Object.Var. If expansion is disabled, as
6500 -- within a generic, we check that the entity appears in the current
6501 -- scope.
6502
6503 if Is_Entity_Name (Cond) then
6504
6505 -- A small optimization of useless renamings. If the scope of the
6506 -- entity of the condition is not the barrier function, then the
6507 -- condition does not reference any of the generated renamings
6508 -- within the function.
6509
6510 if Expander_Active and then Scope (Entity (Cond)) /= Func then
6511 Set_Declarations (B_F, Empty_List);
6512 end if;
6513
6514 if Entity (Cond) = Standard_False
6515 or else
6516 Entity (Cond) = Standard_True
6517 then
6518 return;
6519
6520 elsif Is_Simple_Barrier_Name (Cond) then
6521 return;
6522 end if;
6523 end if;
6524
6525 -- It is not a boolean variable or literal, so check the restriction.
6526 -- Note that it is safe to be calling Check_Restriction from here, even
6527 -- though this is part of the expander, since Expand_Entry_Barrier is
6528 -- called from Sem_Ch9 even in -gnatc mode.
6529
6530 Check_Restriction (Simple_Barriers, Cond);
6531
6532 -- Emit warning if barrier contains global entities and is thus
6533 -- potentially unsynchronized.
6534
6535 Check_Unprotected_Barrier (Cond);
6536 end Expand_Entry_Barrier;
6537
6538 ------------------------------
6539 -- Expand_N_Abort_Statement --
6540 ------------------------------
6541
6542 -- Expand abort T1, T2, .. Tn; into:
6543 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...))
6544
6545 procedure Expand_N_Abort_Statement (N : Node_Id) is
6546 Loc : constant Source_Ptr := Sloc (N);
6547 Tlist : constant List_Id := Names (N);
6548 Count : Nat;
6549 Aggr : Node_Id;
6550 Tasknm : Node_Id;
6551
6552 begin
6553 Aggr := Make_Aggregate (Loc, Component_Associations => New_List);
6554 Count := 0;
6555
6556 Tasknm := First (Tlist);
6557
6558 while Present (Tasknm) loop
6559 Count := Count + 1;
6560
6561 -- A task interface class-wide type object is being aborted. Retrieve
6562 -- its _task_id by calling a dispatching routine.
6563
6564 if Ada_Version >= Ada_2005
6565 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type
6566 and then Is_Interface (Etype (Tasknm))
6567 and then Is_Task_Interface (Etype (Tasknm))
6568 then
6569 Append_To (Component_Associations (Aggr),
6570 Make_Component_Association (Loc,
6571 Choices => New_List (Make_Integer_Literal (Loc, Count)),
6572 Expression =>
6573
6574 -- Task_Id (Tasknm._disp_get_task_id)
6575
6576 Make_Unchecked_Type_Conversion (Loc,
6577 Subtype_Mark =>
6578 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
6579 Expression =>
6580 Make_Selected_Component (Loc,
6581 Prefix => New_Copy_Tree (Tasknm),
6582 Selector_Name =>
6583 Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
6584
6585 else
6586 Append_To (Component_Associations (Aggr),
6587 Make_Component_Association (Loc,
6588 Choices => New_List (Make_Integer_Literal (Loc, Count)),
6589 Expression => Concurrent_Ref (Tasknm)));
6590 end if;
6591
6592 Next (Tasknm);
6593 end loop;
6594
6595 Rewrite (N,
6596 Make_Procedure_Call_Statement (Loc,
6597 Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc),
6598 Parameter_Associations => New_List (
6599 Make_Qualified_Expression (Loc,
6600 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_List), Loc),
6601 Expression => Aggr))));
6602
6603 Analyze (N);
6604 end Expand_N_Abort_Statement;
6605
6606 -------------------------------
6607 -- Expand_N_Accept_Statement --
6608 -------------------------------
6609
6610 -- This procedure handles expansion of accept statements that stand alone,
6611 -- i.e. they are not part of an accept alternative. The expansion of
6612 -- accept statement in accept alternatives is handled by the routines
6613 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
6614 -- following description applies only to stand alone accept statements.
6615
6616 -- If there is no handled statement sequence, or only null statements, then
6617 -- this is called a trivial accept, and the expansion is:
6618
6619 -- Accept_Trivial (entry-index)
6620
6621 -- If there is a handled statement sequence, then the expansion is:
6622
6623 -- Ann : Address;
6624 -- {Lnn : Label}
6625
6626 -- begin
6627 -- begin
6628 -- Accept_Call (entry-index, Ann);
6629 -- Renaming_Declarations for formals
6630 -- <statement sequence from N_Accept_Statement node>
6631 -- Complete_Rendezvous;
6632 -- <<Lnn>>
6633 --
6634 -- exception
6635 -- when ... =>
6636 -- <exception handler from N_Accept_Statement node>
6637 -- Complete_Rendezvous;
6638 -- when ... =>
6639 -- <exception handler from N_Accept_Statement node>
6640 -- Complete_Rendezvous;
6641 -- ...
6642 -- end;
6643
6644 -- exception
6645 -- when all others =>
6646 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
6647 -- end;
6648
6649 -- The first three declarations were already inserted ahead of the accept
6650 -- statement by the Expand_Accept_Declarations procedure, which was called
6651 -- directly from the semantics during analysis of the accept statement,
6652 -- before analyzing its contained statements.
6653
6654 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come
6655 -- from possible expansion activity (the original source of course does
6656 -- not have any declarations associated with the accept statement, since
6657 -- an accept statement has no declarative part). In particular, if the
6658 -- expander is active, the first such declaration is the declaration of
6659 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
6660
6661 -- The two blocks are merged into a single block if the inner block has
6662 -- no exception handlers, but otherwise two blocks are required, since
6663 -- exceptions might be raised in the exception handlers of the inner
6664 -- block, and Exceptional_Complete_Rendezvous must be called.
6665
6666 procedure Expand_N_Accept_Statement (N : Node_Id) is
6667 Loc : constant Source_Ptr := Sloc (N);
6668 Stats : constant Node_Id := Handled_Statement_Sequence (N);
6669 Ename : constant Node_Id := Entry_Direct_Name (N);
6670 Eindx : constant Node_Id := Entry_Index (N);
6671 Eent : constant Entity_Id := Entity (Ename);
6672 Acstack : constant Elist_Id := Accept_Address (Eent);
6673 Ann : constant Entity_Id := Node (Last_Elmt (Acstack));
6674 Ttyp : constant Entity_Id := Etype (Scope (Eent));
6675 Blkent : Entity_Id;
6676 Call : Node_Id;
6677 Block : Node_Id;
6678
6679 begin
6680 -- If the accept statement is not part of a list, then its parent must
6681 -- be an accept alternative, and, as described above, we do not do any
6682 -- expansion for such accept statements at this level.
6683
6684 if not Is_List_Member (N) then
6685 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative);
6686 return;
6687
6688 -- Trivial accept case (no statement sequence, or null statements).
6689 -- If the accept statement has declarations, then just insert them
6690 -- before the procedure call.
6691
6692 elsif Trivial_Accept_OK
6693 and then (No (Stats) or else Null_Statements (Statements (Stats)))
6694 then
6695 -- Remove declarations for renamings, because the parameter block
6696 -- will not be assigned.
6697
6698 declare
6699 D : Node_Id;
6700 Next_D : Node_Id;
6701
6702 begin
6703 D := First (Declarations (N));
6704 while Present (D) loop
6705 Next_D := Next (D);
6706 if Nkind (D) = N_Object_Renaming_Declaration then
6707 Remove (D);
6708 end if;
6709
6710 D := Next_D;
6711 end loop;
6712 end;
6713
6714 if Present (Declarations (N)) then
6715 Insert_Actions (N, Declarations (N));
6716 end if;
6717
6718 Rewrite (N,
6719 Make_Procedure_Call_Statement (Loc,
6720 Name => New_Occurrence_Of (RTE (RE_Accept_Trivial), Loc),
6721 Parameter_Associations => New_List (
6722 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp))));
6723
6724 Analyze (N);
6725
6726 -- Discard Entry_Address that was created for it, so it will not be
6727 -- emitted if this accept statement is in the statement part of a
6728 -- delay alternative.
6729
6730 if Present (Stats) then
6731 Remove_Last_Elmt (Acstack);
6732 end if;
6733
6734 -- Case of statement sequence present
6735
6736 else
6737 -- Construct the block, using the declarations from the accept
6738 -- statement if any to initialize the declarations of the block.
6739
6740 Blkent := Make_Temporary (Loc, 'A');
6741 Set_Ekind (Blkent, E_Block);
6742 Set_Etype (Blkent, Standard_Void_Type);
6743 Set_Scope (Blkent, Current_Scope);
6744
6745 Block :=
6746 Make_Block_Statement (Loc,
6747 Identifier => New_Occurrence_Of (Blkent, Loc),
6748 Declarations => Declarations (N),
6749 Handled_Statement_Sequence => Build_Accept_Body (N));
6750
6751 -- For the analysis of the generated declarations, the parent node
6752 -- must be properly set.
6753
6754 Set_Parent (Block, Parent (N));
6755
6756 -- Prepend call to Accept_Call to main statement sequence If the
6757 -- accept has exception handlers, the statement sequence is wrapped
6758 -- in a block. Insert call and renaming declarations in the
6759 -- declarations of the block, so they are elaborated before the
6760 -- handlers.
6761
6762 Call :=
6763 Make_Procedure_Call_Statement (Loc,
6764 Name => New_Occurrence_Of (RTE (RE_Accept_Call), Loc),
6765 Parameter_Associations => New_List (
6766 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp),
6767 New_Occurrence_Of (Ann, Loc)));
6768
6769 if Parent (Stats) = N then
6770 Prepend (Call, Statements (Stats));
6771 else
6772 Set_Declarations (Parent (Stats), New_List (Call));
6773 end if;
6774
6775 Analyze (Call);
6776
6777 Push_Scope (Blkent);
6778
6779 declare
6780 D : Node_Id;
6781 Next_D : Node_Id;
6782 Typ : Entity_Id;
6783
6784 begin
6785 D := First (Declarations (N));
6786 while Present (D) loop
6787 Next_D := Next (D);
6788
6789 if Nkind (D) = N_Object_Renaming_Declaration then
6790
6791 -- The renaming declarations for the formals were created
6792 -- during analysis of the accept statement, and attached to
6793 -- the list of declarations. Place them now in the context
6794 -- of the accept block or subprogram.
6795
6796 Remove (D);
6797 Typ := Entity (Subtype_Mark (D));
6798 Insert_After (Call, D);
6799 Analyze (D);
6800
6801 -- If the formal is class_wide, it does not have an actual
6802 -- subtype. The analysis of the renaming declaration creates
6803 -- one, but we need to retain the class-wide nature of the
6804 -- entity.
6805
6806 if Is_Class_Wide_Type (Typ) then
6807 Set_Etype (Defining_Identifier (D), Typ);
6808 end if;
6809
6810 end if;
6811
6812 D := Next_D;
6813 end loop;
6814 end;
6815
6816 End_Scope;
6817
6818 -- Replace the accept statement by the new block
6819
6820 Rewrite (N, Block);
6821 Analyze (N);
6822
6823 -- Last step is to unstack the Accept_Address value
6824
6825 Remove_Last_Elmt (Acstack);
6826 end if;
6827 end Expand_N_Accept_Statement;
6828
6829 ----------------------------------
6830 -- Expand_N_Asynchronous_Select --
6831 ----------------------------------
6832
6833 -- This procedure assumes that the trigger statement is an entry call or
6834 -- a dispatching procedure call. A delay alternative should already have
6835 -- been expanded into an entry call to the appropriate delay object Wait
6836 -- entry.
6837
6838 -- If the trigger is a task entry call, the select is implemented with
6839 -- a Task_Entry_Call:
6840
6841 -- declare
6842 -- B : Boolean;
6843 -- C : Boolean;
6844 -- P : parms := (parm, parm, parm);
6845
6846 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6847
6848 -- procedure _clean is
6849 -- begin
6850 -- ...
6851 -- Cancel_Task_Entry_Call (C);
6852 -- ...
6853 -- end _clean;
6854
6855 -- begin
6856 -- Abort_Defer;
6857 -- Task_Entry_Call
6858 -- (<acceptor-task>, -- Acceptor
6859 -- <entry-index>, -- E
6860 -- P'Address, -- Uninterpreted_Data
6861 -- Asynchronous_Call, -- Mode
6862 -- B); -- Rendezvous_Successful
6863
6864 -- begin
6865 -- begin
6866 -- Abort_Undefer;
6867 -- <abortable-part>
6868 -- at end
6869 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6870 -- end;
6871 -- exception
6872 -- when Abort_Signal => Abort_Undefer;
6873 -- end;
6874
6875 -- parm := P.param;
6876 -- parm := P.param;
6877 -- ...
6878 -- if not C then
6879 -- <triggered-statements>
6880 -- end if;
6881 -- end;
6882
6883 -- Note that Build_Simple_Entry_Call is used to expand the entry of the
6884 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure)
6885 -- as follows:
6886
6887 -- declare
6888 -- P : parms := (parm, parm, parm);
6889 -- begin
6890 -- Call_Simple (acceptor-task, entry-index, P'Address);
6891 -- parm := P.param;
6892 -- parm := P.param;
6893 -- ...
6894 -- end;
6895
6896 -- so the task at hand is to convert the latter expansion into the former
6897
6898 -- If the trigger is a protected entry call, the select is implemented
6899 -- with Protected_Entry_Call:
6900
6901 -- declare
6902 -- P : E1_Params := (param, param, param);
6903 -- Bnn : Communications_Block;
6904
6905 -- begin
6906 -- declare
6907
6908 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions
6909
6910 -- procedure _clean is
6911 -- begin
6912 -- ...
6913 -- if Enqueued (Bnn) then
6914 -- Cancel_Protected_Entry_Call (Bnn);
6915 -- end if;
6916 -- ...
6917 -- end _clean;
6918
6919 -- begin
6920 -- begin
6921 -- Protected_Entry_Call
6922 -- (po._object'Access, -- Object
6923 -- <entry index>, -- E
6924 -- P'Address, -- Uninterpreted_Data
6925 -- Asynchronous_Call, -- Mode
6926 -- Bnn); -- Block
6927
6928 -- if Enqueued (Bnn) then
6929 -- <abortable-part>
6930 -- end if;
6931 -- at end
6932 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
6933 -- end;
6934 -- exception
6935 -- when Abort_Signal => Abort_Undefer;
6936 -- end;
6937
6938 -- if not Cancelled (Bnn) then
6939 -- <triggered-statements>
6940 -- end if;
6941 -- end;
6942
6943 -- Build_Simple_Entry_Call is used to expand the all to a simple protected
6944 -- entry call:
6945
6946 -- declare
6947 -- P : E1_Params := (param, param, param);
6948 -- Bnn : Communications_Block;
6949
6950 -- begin
6951 -- Protected_Entry_Call
6952 -- (po._object'Access, -- Object
6953 -- <entry index>, -- E
6954 -- P'Address, -- Uninterpreted_Data
6955 -- Simple_Call, -- Mode
6956 -- Bnn); -- Block
6957 -- parm := P.param;
6958 -- parm := P.param;
6959 -- ...
6960 -- end;
6961
6962 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is
6963 -- expanded into:
6964
6965 -- declare
6966 -- B : Boolean := False;
6967 -- Bnn : Communication_Block;
6968 -- C : Ada.Tags.Prim_Op_Kind;
6969 -- D : System.Storage_Elements.Dummy_Communication_Block;
6970 -- K : Ada.Tags.Tagged_Kind :=
6971 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
6972 -- P : Parameters := (Param1 .. ParamN);
6973 -- S : Integer;
6974 -- U : Boolean;
6975
6976 -- begin
6977 -- if K = Ada.Tags.TK_Limited_Tagged
6978 -- or else K = Ada.Tags.TK_Tagged
6979 -- then
6980 -- <dispatching-call>;
6981 -- <triggering-statements>;
6982
6983 -- else
6984 -- S :=
6985 -- Ada.Tags.Get_Offset_Index
6986 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
6987
6988 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
6989
6990 -- if C = POK_Protected_Entry then
6991 -- declare
6992 -- procedure _clean is
6993 -- begin
6994 -- if Enqueued (Bnn) then
6995 -- Cancel_Protected_Entry_Call (Bnn);
6996 -- end if;
6997 -- end _clean;
6998
6999 -- begin
7000 -- begin
7001 -- _Disp_Asynchronous_Select
7002 -- (<object>, S, P'Address, D, B);
7003 -- Bnn := Communication_Block (D);
7004
7005 -- Param1 := P.Param1;
7006 -- ...
7007 -- ParamN := P.ParamN;
7008
7009 -- if Enqueued (Bnn) then
7010 -- <abortable-statements>
7011 -- end if;
7012 -- at end
7013 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
7014 -- end;
7015 -- exception
7016 -- when Abort_Signal => Abort_Undefer;
7017 -- end;
7018
7019 -- if not Cancelled (Bnn) then
7020 -- <triggering-statements>
7021 -- end if;
7022
7023 -- elsif C = POK_Task_Entry then
7024 -- declare
7025 -- procedure _clean is
7026 -- begin
7027 -- Cancel_Task_Entry_Call (U);
7028 -- end _clean;
7029
7030 -- begin
7031 -- Abort_Defer;
7032
7033 -- _Disp_Asynchronous_Select
7034 -- (<object>, S, P'Address, D, B);
7035 -- Bnn := Communication_Bloc (D);
7036
7037 -- Param1 := P.Param1;
7038 -- ...
7039 -- ParamN := P.ParamN;
7040
7041 -- begin
7042 -- begin
7043 -- Abort_Undefer;
7044 -- <abortable-statements>
7045 -- at end
7046 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions
7047 -- end;
7048 -- exception
7049 -- when Abort_Signal => Abort_Undefer;
7050 -- end;
7051
7052 -- if not U then
7053 -- <triggering-statements>
7054 -- end if;
7055 -- end;
7056
7057 -- else
7058 -- <dispatching-call>;
7059 -- <triggering-statements>
7060 -- end if;
7061 -- end if;
7062 -- end;
7063
7064 -- The job is to convert this to the asynchronous form
7065
7066 -- If the trigger is a delay statement, it will have been expanded into
7067 -- a call to one of the GNARL delay procedures. This routine will convert
7068 -- this into a protected entry call on a delay object and then continue
7069 -- processing as for a protected entry call trigger. This requires
7070 -- declaring a Delay_Block object and adding a pointer to this object to
7071 -- the parameter list of the delay procedure to form the parameter list of
7072 -- the entry call. This object is used by the runtime to queue the delay
7073 -- request.
7074
7075 -- For a description of the use of P and the assignments after the call,
7076 -- see Expand_N_Entry_Call_Statement.
7077
7078 procedure Expand_N_Asynchronous_Select (N : Node_Id) is
7079 Loc : constant Source_Ptr := Sloc (N);
7080 Abrt : constant Node_Id := Abortable_Part (N);
7081 Trig : constant Node_Id := Triggering_Alternative (N);
7082
7083 Abort_Block_Ent : Entity_Id;
7084 Abortable_Block : Node_Id;
7085 Actuals : List_Id;
7086 Astats : List_Id;
7087 Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A');
7088 Blk_Typ : Entity_Id;
7089 Call : Node_Id;
7090 Call_Ent : Entity_Id;
7091 Cancel_Param : Entity_Id;
7092 Cleanup_Block : Node_Id;
7093 Cleanup_Block_Ent : Entity_Id;
7094 Cleanup_Stmts : List_Id;
7095 Conc_Typ_Stmts : List_Id;
7096 Concval : Node_Id;
7097 Dblock_Ent : Entity_Id;
7098 Decl : Node_Id;
7099 Decls : List_Id;
7100 Ecall : Node_Id;
7101 Ename : Node_Id;
7102 Enqueue_Call : Node_Id;
7103 Formals : List_Id;
7104 Hdle : List_Id;
7105 Handler_Stmt : Node_Id;
7106 Index : Node_Id;
7107 Lim_Typ_Stmts : List_Id;
7108 N_Orig : Node_Id;
7109 Obj : Entity_Id;
7110 Param : Node_Id;
7111 Params : List_Id;
7112 Pdef : Entity_Id;
7113 ProtE_Stmts : List_Id;
7114 ProtP_Stmts : List_Id;
7115 Stmt : Node_Id;
7116 Stmts : List_Id;
7117 TaskE_Stmts : List_Id;
7118 Tstats : List_Id;
7119
7120 B : Entity_Id; -- Call status flag
7121 Bnn : Entity_Id; -- Communication block
7122 C : Entity_Id; -- Call kind
7123 K : Entity_Id; -- Tagged kind
7124 P : Entity_Id; -- Parameter block
7125 S : Entity_Id; -- Primitive operation slot
7126 T : Entity_Id; -- Additional status flag
7127
7128 procedure Rewrite_Abortable_Part;
7129 -- If the trigger is a dispatching call, the expansion inserts multiple
7130 -- copies of the abortable part. This is both inefficient, and may lead
7131 -- to duplicate definitions that the back-end will reject, when the
7132 -- abortable part includes loops. This procedure rewrites the abortable
7133 -- part into a call to a generated procedure.
7134
7135 ----------------------------
7136 -- Rewrite_Abortable_Part --
7137 ----------------------------
7138
7139 procedure Rewrite_Abortable_Part is
7140 Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
7141 Decl : Node_Id;
7142
7143 begin
7144 Decl :=
7145 Make_Subprogram_Body (Loc,
7146 Specification =>
7147 Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc),
7148 Declarations => New_List,
7149 Handled_Statement_Sequence =>
7150 Make_Handled_Sequence_Of_Statements (Loc, Astats));
7151 Insert_Before (N, Decl);
7152 Analyze (Decl);
7153
7154 -- Rewrite abortable part into a call to this procedure.
7155
7156 Astats :=
7157 New_List (
7158 Make_Procedure_Call_Statement (Loc,
7159 Name => New_Occurrence_Of (Proc, Loc)));
7160 end Rewrite_Abortable_Part;
7161
7162 -- Start of processing for Expand_N_Asynchronous_Select
7163
7164 begin
7165 Process_Statements_For_Controlled_Objects (Trig);
7166 Process_Statements_For_Controlled_Objects (Abrt);
7167
7168 Ecall := Triggering_Statement (Trig);
7169
7170 Ensure_Statement_Present (Sloc (Ecall), Trig);
7171
7172 -- Retrieve Astats and Tstats now because the finalization machinery may
7173 -- wrap them in blocks.
7174
7175 Astats := Statements (Abrt);
7176 Tstats := Statements (Trig);
7177
7178 -- The arguments in the call may require dynamic allocation, and the
7179 -- call statement may have been transformed into a block. The block
7180 -- may contain additional declarations for internal entities, and the
7181 -- original call is found by sequential search.
7182
7183 if Nkind (Ecall) = N_Block_Statement then
7184 Ecall := First (Statements (Handled_Statement_Sequence (Ecall)));
7185 while not Nkind_In (Ecall, N_Procedure_Call_Statement,
7186 N_Entry_Call_Statement)
7187 loop
7188 Next (Ecall);
7189 end loop;
7190 end if;
7191
7192 -- This is either a dispatching call or a delay statement used as a
7193 -- trigger which was expanded into a procedure call.
7194
7195 if Nkind (Ecall) = N_Procedure_Call_Statement then
7196 if Ada_Version >= Ada_2005
7197 and then
7198 (No (Original_Node (Ecall))
7199 or else not Nkind_In (Original_Node (Ecall),
7200 N_Delay_Relative_Statement,
7201 N_Delay_Until_Statement))
7202 then
7203 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals);
7204
7205 Rewrite_Abortable_Part;
7206 Decls := New_List;
7207 Stmts := New_List;
7208
7209 -- Call status flag processing, generate:
7210 -- B : Boolean := False;
7211
7212 B := Build_B (Loc, Decls);
7213
7214 -- Communication block processing, generate:
7215 -- Bnn : Communication_Block;
7216
7217 Bnn := Make_Temporary (Loc, 'B');
7218 Append_To (Decls,
7219 Make_Object_Declaration (Loc,
7220 Defining_Identifier => Bnn,
7221 Object_Definition =>
7222 New_Occurrence_Of (RTE (RE_Communication_Block), Loc)));
7223
7224 -- Call kind processing, generate:
7225 -- C : Ada.Tags.Prim_Op_Kind;
7226
7227 C := Build_C (Loc, Decls);
7228
7229 -- Tagged kind processing, generate:
7230 -- K : Ada.Tags.Tagged_Kind :=
7231 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
7232
7233 -- Dummy communication block, generate:
7234 -- D : Dummy_Communication_Block;
7235
7236 Append_To (Decls,
7237 Make_Object_Declaration (Loc,
7238 Defining_Identifier =>
7239 Make_Defining_Identifier (Loc, Name_uD),
7240 Object_Definition =>
7241 New_Occurrence_Of
7242 (RTE (RE_Dummy_Communication_Block), Loc)));
7243
7244 K := Build_K (Loc, Decls, Obj);
7245
7246 -- Parameter block processing
7247
7248 Blk_Typ := Build_Parameter_Block
7249 (Loc, Actuals, Formals, Decls);
7250 P := Parameter_Block_Pack
7251 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
7252
7253 -- Dispatch table slot processing, generate:
7254 -- S : Integer;
7255
7256 S := Build_S (Loc, Decls);
7257
7258 -- Additional status flag processing, generate:
7259 -- Tnn : Boolean;
7260
7261 T := Make_Temporary (Loc, 'T');
7262 Append_To (Decls,
7263 Make_Object_Declaration (Loc,
7264 Defining_Identifier => T,
7265 Object_Definition =>
7266 New_Occurrence_Of (Standard_Boolean, Loc)));
7267
7268 ------------------------------
7269 -- Protected entry handling --
7270 ------------------------------
7271
7272 -- Generate:
7273 -- Param1 := P.Param1;
7274 -- ...
7275 -- ParamN := P.ParamN;
7276
7277 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
7278
7279 -- Generate:
7280 -- Bnn := Communication_Block (D);
7281
7282 Prepend_To (Cleanup_Stmts,
7283 Make_Assignment_Statement (Loc,
7284 Name => New_Occurrence_Of (Bnn, Loc),
7285 Expression =>
7286 Make_Unchecked_Type_Conversion (Loc,
7287 Subtype_Mark =>
7288 New_Occurrence_Of (RTE (RE_Communication_Block), Loc),
7289 Expression => Make_Identifier (Loc, Name_uD))));
7290
7291 -- Generate:
7292 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7293
7294 Prepend_To (Cleanup_Stmts,
7295 Make_Procedure_Call_Statement (Loc,
7296 Name =>
7297 New_Occurrence_Of
7298 (Find_Prim_Op
7299 (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select),
7300 Loc),
7301 Parameter_Associations =>
7302 New_List (
7303 New_Copy_Tree (Obj), -- <object>
7304 New_Occurrence_Of (S, Loc), -- S
7305 Make_Attribute_Reference (Loc, -- P'Address
7306 Prefix => New_Occurrence_Of (P, Loc),
7307 Attribute_Name => Name_Address),
7308 Make_Identifier (Loc, Name_uD), -- D
7309 New_Occurrence_Of (B, Loc)))); -- B
7310
7311 -- Generate:
7312 -- if Enqueued (Bnn) then
7313 -- <abortable-statements>
7314 -- end if;
7315
7316 Append_To (Cleanup_Stmts,
7317 Make_Implicit_If_Statement (N,
7318 Condition =>
7319 Make_Function_Call (Loc,
7320 Name =>
7321 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
7322 Parameter_Associations =>
7323 New_List (New_Occurrence_Of (Bnn, Loc))),
7324
7325 Then_Statements =>
7326 New_Copy_List_Tree (Astats)));
7327
7328 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7329 -- will then generate a _clean for the communication block Bnn.
7330
7331 -- Generate:
7332 -- declare
7333 -- procedure _clean is
7334 -- begin
7335 -- if Enqueued (Bnn) then
7336 -- Cancel_Protected_Entry_Call (Bnn);
7337 -- end if;
7338 -- end _clean;
7339 -- begin
7340 -- Cleanup_Stmts
7341 -- at end
7342 -- _clean;
7343 -- end;
7344
7345 Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
7346 Cleanup_Block :=
7347 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn);
7348
7349 -- Wrap the cleanup block in an exception handling block
7350
7351 -- Generate:
7352 -- begin
7353 -- Cleanup_Block
7354 -- exception
7355 -- when Abort_Signal => Abort_Undefer;
7356 -- end;
7357
7358 Abort_Block_Ent := Make_Temporary (Loc, 'A');
7359 ProtE_Stmts :=
7360 New_List (
7361 Make_Implicit_Label_Declaration (Loc,
7362 Defining_Identifier => Abort_Block_Ent),
7363
7364 Build_Abort_Block
7365 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
7366
7367 -- Generate:
7368 -- if not Cancelled (Bnn) then
7369 -- <triggering-statements>
7370 -- end if;
7371
7372 Append_To (ProtE_Stmts,
7373 Make_Implicit_If_Statement (N,
7374 Condition =>
7375 Make_Op_Not (Loc,
7376 Right_Opnd =>
7377 Make_Function_Call (Loc,
7378 Name =>
7379 New_Occurrence_Of (RTE (RE_Cancelled), Loc),
7380 Parameter_Associations =>
7381 New_List (New_Occurrence_Of (Bnn, Loc)))),
7382
7383 Then_Statements =>
7384 New_Copy_List_Tree (Tstats)));
7385
7386 -------------------------
7387 -- Task entry handling --
7388 -------------------------
7389
7390 -- Generate:
7391 -- Param1 := P.Param1;
7392 -- ...
7393 -- ParamN := P.ParamN;
7394
7395 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
7396
7397 -- Generate:
7398 -- Bnn := Communication_Block (D);
7399
7400 Append_To (TaskE_Stmts,
7401 Make_Assignment_Statement (Loc,
7402 Name =>
7403 New_Occurrence_Of (Bnn, Loc),
7404 Expression =>
7405 Make_Unchecked_Type_Conversion (Loc,
7406 Subtype_Mark =>
7407 New_Occurrence_Of (RTE (RE_Communication_Block), Loc),
7408 Expression => Make_Identifier (Loc, Name_uD))));
7409
7410 -- Generate:
7411 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B);
7412
7413 Prepend_To (TaskE_Stmts,
7414 Make_Procedure_Call_Statement (Loc,
7415 Name =>
7416 New_Occurrence_Of (
7417 Find_Prim_Op (Etype (Etype (Obj)),
7418 Name_uDisp_Asynchronous_Select),
7419 Loc),
7420
7421 Parameter_Associations => New_List (
7422 New_Copy_Tree (Obj), -- <object>
7423 New_Occurrence_Of (S, Loc), -- S
7424 Make_Attribute_Reference (Loc, -- P'Address
7425 Prefix => New_Occurrence_Of (P, Loc),
7426 Attribute_Name => Name_Address),
7427 Make_Identifier (Loc, Name_uD), -- D
7428 New_Occurrence_Of (B, Loc)))); -- B
7429
7430 -- Generate:
7431 -- Abort_Defer;
7432
7433 Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7434
7435 -- Generate:
7436 -- Abort_Undefer;
7437 -- <abortable-statements>
7438
7439 Cleanup_Stmts := New_Copy_List_Tree (Astats);
7440
7441 Prepend_To
7442 (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7443
7444 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions
7445 -- will generate a _clean for the additional status flag.
7446
7447 -- Generate:
7448 -- declare
7449 -- procedure _clean is
7450 -- begin
7451 -- Cancel_Task_Entry_Call (U);
7452 -- end _clean;
7453 -- begin
7454 -- Cleanup_Stmts
7455 -- at end
7456 -- _clean;
7457 -- end;
7458
7459 Cleanup_Block_Ent := Make_Temporary (Loc, 'C');
7460 Cleanup_Block :=
7461 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T);
7462
7463 -- Wrap the cleanup block in an exception handling block
7464
7465 -- Generate:
7466 -- begin
7467 -- Cleanup_Block
7468 -- exception
7469 -- when Abort_Signal => Abort_Undefer;
7470 -- end;
7471
7472 Abort_Block_Ent := Make_Temporary (Loc, 'A');
7473
7474 Append_To (TaskE_Stmts,
7475 Make_Implicit_Label_Declaration (Loc,
7476 Defining_Identifier => Abort_Block_Ent));
7477
7478 Append_To (TaskE_Stmts,
7479 Build_Abort_Block
7480 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block));
7481
7482 -- Generate:
7483 -- if not T then
7484 -- <triggering-statements>
7485 -- end if;
7486
7487 Append_To (TaskE_Stmts,
7488 Make_Implicit_If_Statement (N,
7489 Condition =>
7490 Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)),
7491
7492 Then_Statements =>
7493 New_Copy_List_Tree (Tstats)));
7494
7495 ----------------------------------
7496 -- Protected procedure handling --
7497 ----------------------------------
7498
7499 -- Generate:
7500 -- <dispatching-call>;
7501 -- <triggering-statements>
7502
7503 ProtP_Stmts := New_Copy_List_Tree (Tstats);
7504 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall));
7505
7506 -- Generate:
7507 -- S := Ada.Tags.Get_Offset_Index
7508 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
7509
7510 Conc_Typ_Stmts :=
7511 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
7512
7513 -- Generate:
7514 -- _Disp_Get_Prim_Op_Kind (<object>, S, C);
7515
7516 Append_To (Conc_Typ_Stmts,
7517 Make_Procedure_Call_Statement (Loc,
7518 Name =>
7519 New_Occurrence_Of
7520 (Find_Prim_Op (Etype (Etype (Obj)),
7521 Name_uDisp_Get_Prim_Op_Kind),
7522 Loc),
7523 Parameter_Associations =>
7524 New_List (
7525 New_Copy_Tree (Obj),
7526 New_Occurrence_Of (S, Loc),
7527 New_Occurrence_Of (C, Loc))));
7528
7529 -- Generate:
7530 -- if C = POK_Procedure_Entry then
7531 -- ProtE_Stmts
7532 -- elsif C = POK_Task_Entry then
7533 -- TaskE_Stmts
7534 -- else
7535 -- ProtP_Stmts
7536 -- end if;
7537
7538 Append_To (Conc_Typ_Stmts,
7539 Make_Implicit_If_Statement (N,
7540 Condition =>
7541 Make_Op_Eq (Loc,
7542 Left_Opnd =>
7543 New_Occurrence_Of (C, Loc),
7544 Right_Opnd =>
7545 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)),
7546
7547 Then_Statements =>
7548 ProtE_Stmts,
7549
7550 Elsif_Parts =>
7551 New_List (
7552 Make_Elsif_Part (Loc,
7553 Condition =>
7554 Make_Op_Eq (Loc,
7555 Left_Opnd =>
7556 New_Occurrence_Of (C, Loc),
7557 Right_Opnd =>
7558 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)),
7559
7560 Then_Statements =>
7561 TaskE_Stmts)),
7562
7563 Else_Statements =>
7564 ProtP_Stmts));
7565
7566 -- Generate:
7567 -- <dispatching-call>;
7568 -- <triggering-statements>
7569
7570 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats);
7571 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall));
7572
7573 -- Generate:
7574 -- if K = Ada.Tags.TK_Limited_Tagged
7575 -- or else K = Ada.Tags.TK_Tagged
7576 -- then
7577 -- Lim_Typ_Stmts
7578 -- else
7579 -- Conc_Typ_Stmts
7580 -- end if;
7581
7582 Append_To (Stmts,
7583 Make_Implicit_If_Statement (N,
7584 Condition => Build_Dispatching_Tag_Check (K, N),
7585 Then_Statements => Lim_Typ_Stmts,
7586 Else_Statements => Conc_Typ_Stmts));
7587
7588 Rewrite (N,
7589 Make_Block_Statement (Loc,
7590 Declarations =>
7591 Decls,
7592 Handled_Statement_Sequence =>
7593 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7594
7595 Analyze (N);
7596 return;
7597
7598 -- Delay triggering statement processing
7599
7600 else
7601 -- Add a Delay_Block object to the parameter list of the delay
7602 -- procedure to form the parameter list of the Wait entry call.
7603
7604 Dblock_Ent := Make_Temporary (Loc, 'D');
7605
7606 Pdef := Entity (Name (Ecall));
7607
7608 if Is_RTE (Pdef, RO_CA_Delay_For) then
7609 Enqueue_Call :=
7610 New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc);
7611
7612 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then
7613 Enqueue_Call :=
7614 New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc);
7615
7616 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until));
7617 Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc);
7618 end if;
7619
7620 Append_To (Parameter_Associations (Ecall),
7621 Make_Attribute_Reference (Loc,
7622 Prefix => New_Occurrence_Of (Dblock_Ent, Loc),
7623 Attribute_Name => Name_Unchecked_Access));
7624
7625 -- Create the inner block to protect the abortable part
7626
7627 Hdle := New_List (Build_Abort_Block_Handler (Loc));
7628
7629 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7630
7631 Abortable_Block :=
7632 Make_Block_Statement (Loc,
7633 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7634 Handled_Statement_Sequence =>
7635 Make_Handled_Sequence_Of_Statements (Loc,
7636 Statements => Astats),
7637 Has_Created_Identifier => True,
7638 Is_Asynchronous_Call_Block => True);
7639
7640 -- Append call to if Enqueue (When, DB'Unchecked_Access) then
7641
7642 Rewrite (Ecall,
7643 Make_Implicit_If_Statement (N,
7644 Condition =>
7645 Make_Function_Call (Loc,
7646 Name => Enqueue_Call,
7647 Parameter_Associations => Parameter_Associations (Ecall)),
7648 Then_Statements =>
7649 New_List (Make_Block_Statement (Loc,
7650 Handled_Statement_Sequence =>
7651 Make_Handled_Sequence_Of_Statements (Loc,
7652 Statements => New_List (
7653 Make_Implicit_Label_Declaration (Loc,
7654 Defining_Identifier => Blk_Ent,
7655 Label_Construct => Abortable_Block),
7656 Abortable_Block),
7657 Exception_Handlers => Hdle)))));
7658
7659 Stmts := New_List (Ecall);
7660
7661 -- Construct statement sequence for new block
7662
7663 Append_To (Stmts,
7664 Make_Implicit_If_Statement (N,
7665 Condition =>
7666 Make_Function_Call (Loc,
7667 Name => New_Occurrence_Of (
7668 RTE (RE_Timed_Out), Loc),
7669 Parameter_Associations => New_List (
7670 Make_Attribute_Reference (Loc,
7671 Prefix => New_Occurrence_Of (Dblock_Ent, Loc),
7672 Attribute_Name => Name_Unchecked_Access))),
7673 Then_Statements => Tstats));
7674
7675 -- The result is the new block
7676
7677 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent);
7678
7679 Rewrite (N,
7680 Make_Block_Statement (Loc,
7681 Declarations => New_List (
7682 Make_Object_Declaration (Loc,
7683 Defining_Identifier => Dblock_Ent,
7684 Aliased_Present => True,
7685 Object_Definition =>
7686 New_Occurrence_Of (RTE (RE_Delay_Block), Loc))),
7687
7688 Handled_Statement_Sequence =>
7689 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7690
7691 Analyze (N);
7692 return;
7693 end if;
7694
7695 else
7696 N_Orig := N;
7697 end if;
7698
7699 Extract_Entry (Ecall, Concval, Ename, Index);
7700 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index);
7701
7702 Stmts := Statements (Handled_Statement_Sequence (Ecall));
7703 Decls := Declarations (Ecall);
7704
7705 if Is_Protected_Type (Etype (Concval)) then
7706
7707 -- Get the declarations of the block expanded from the entry call
7708
7709 Decl := First (Decls);
7710 while Present (Decl)
7711 and then (Nkind (Decl) /= N_Object_Declaration
7712 or else not Is_RTE (Etype (Object_Definition (Decl)),
7713 RE_Communication_Block))
7714 loop
7715 Next (Decl);
7716 end loop;
7717
7718 pragma Assert (Present (Decl));
7719 Cancel_Param := Defining_Identifier (Decl);
7720
7721 -- Change the mode of the Protected_Entry_Call call
7722
7723 -- Protected_Entry_Call (
7724 -- Object => po._object'Access,
7725 -- E => <entry index>;
7726 -- Uninterpreted_Data => P'Address;
7727 -- Mode => Asynchronous_Call;
7728 -- Block => Bnn);
7729
7730 -- Skip assignments to temporaries created for in-out parameters
7731
7732 -- This makes unwarranted assumptions about the shape of the expanded
7733 -- tree for the call, and should be cleaned up ???
7734
7735 Stmt := First (Stmts);
7736 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7737 Next (Stmt);
7738 end loop;
7739
7740 Call := Stmt;
7741
7742 Param := First (Parameter_Associations (Call));
7743 while Present (Param)
7744 and then not Is_RTE (Etype (Param), RE_Call_Modes)
7745 loop
7746 Next (Param);
7747 end loop;
7748
7749 pragma Assert (Present (Param));
7750 Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc));
7751 Analyze (Param);
7752
7753 -- Append an if statement to execute the abortable part
7754
7755 -- Generate:
7756 -- if Enqueued (Bnn) then
7757
7758 Append_To (Stmts,
7759 Make_Implicit_If_Statement (N,
7760 Condition =>
7761 Make_Function_Call (Loc,
7762 Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc),
7763 Parameter_Associations => New_List (
7764 New_Occurrence_Of (Cancel_Param, Loc))),
7765 Then_Statements => Astats));
7766
7767 Abortable_Block :=
7768 Make_Block_Statement (Loc,
7769 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7770 Handled_Statement_Sequence =>
7771 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts),
7772 Has_Created_Identifier => True,
7773 Is_Asynchronous_Call_Block => True);
7774
7775 -- Aborts are not deferred at beginning of exception handlers in
7776 -- ZCX mode.
7777
7778 if ZCX_Exceptions then
7779 Handler_Stmt := Make_Null_Statement (Loc);
7780
7781 else
7782 Handler_Stmt := Build_Runtime_Call (Loc, RE_Abort_Undefer);
7783 end if;
7784
7785 Stmts := New_List (
7786 Make_Block_Statement (Loc,
7787 Handled_Statement_Sequence =>
7788 Make_Handled_Sequence_Of_Statements (Loc,
7789 Statements => New_List (
7790 Make_Implicit_Label_Declaration (Loc,
7791 Defining_Identifier => Blk_Ent,
7792 Label_Construct => Abortable_Block),
7793 Abortable_Block),
7794
7795 -- exception
7796
7797 Exception_Handlers => New_List (
7798 Make_Implicit_Exception_Handler (Loc,
7799
7800 -- when Abort_Signal =>
7801 -- Abort_Undefer.all;
7802
7803 Exception_Choices =>
7804 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)),
7805 Statements => New_List (Handler_Stmt))))),
7806
7807 -- if not Cancelled (Bnn) then
7808 -- triggered statements
7809 -- end if;
7810
7811 Make_Implicit_If_Statement (N,
7812 Condition => Make_Op_Not (Loc,
7813 Right_Opnd =>
7814 Make_Function_Call (Loc,
7815 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
7816 Parameter_Associations => New_List (
7817 New_Occurrence_Of (Cancel_Param, Loc)))),
7818 Then_Statements => Tstats));
7819
7820 -- Asynchronous task entry call
7821
7822 else
7823 if No (Decls) then
7824 Decls := New_List;
7825 end if;
7826
7827 B := Make_Defining_Identifier (Loc, Name_uB);
7828
7829 -- Insert declaration of B in declarations of existing block
7830
7831 Prepend_To (Decls,
7832 Make_Object_Declaration (Loc,
7833 Defining_Identifier => B,
7834 Object_Definition =>
7835 New_Occurrence_Of (Standard_Boolean, Loc)));
7836
7837 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC);
7838
7839 -- Insert declaration of C in declarations of existing block
7840
7841 Prepend_To (Decls,
7842 Make_Object_Declaration (Loc,
7843 Defining_Identifier => Cancel_Param,
7844 Object_Definition =>
7845 New_Occurrence_Of (Standard_Boolean, Loc)));
7846
7847 -- Remove and save the call to Call_Simple
7848
7849 Stmt := First (Stmts);
7850
7851 -- Skip assignments to temporaries created for in-out parameters.
7852 -- This makes unwarranted assumptions about the shape of the expanded
7853 -- tree for the call, and should be cleaned up ???
7854
7855 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
7856 Next (Stmt);
7857 end loop;
7858
7859 Call := Stmt;
7860
7861 -- Create the inner block to protect the abortable part
7862
7863 Hdle := New_List (Build_Abort_Block_Handler (Loc));
7864
7865 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7866
7867 Abortable_Block :=
7868 Make_Block_Statement (Loc,
7869 Identifier => New_Occurrence_Of (Blk_Ent, Loc),
7870 Handled_Statement_Sequence =>
7871 Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats),
7872 Has_Created_Identifier => True,
7873 Is_Asynchronous_Call_Block => True);
7874
7875 Insert_After (Call,
7876 Make_Block_Statement (Loc,
7877 Handled_Statement_Sequence =>
7878 Make_Handled_Sequence_Of_Statements (Loc,
7879 Statements => New_List (
7880 Make_Implicit_Label_Declaration (Loc,
7881 Defining_Identifier => Blk_Ent,
7882 Label_Construct => Abortable_Block),
7883 Abortable_Block),
7884 Exception_Handlers => Hdle)));
7885
7886 -- Create new call statement
7887
7888 Params := Parameter_Associations (Call);
7889
7890 Append_To (Params,
7891 New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc));
7892 Append_To (Params, New_Occurrence_Of (B, Loc));
7893
7894 Rewrite (Call,
7895 Make_Procedure_Call_Statement (Loc,
7896 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
7897 Parameter_Associations => Params));
7898
7899 -- Construct statement sequence for new block
7900
7901 Append_To (Stmts,
7902 Make_Implicit_If_Statement (N,
7903 Condition =>
7904 Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)),
7905 Then_Statements => Tstats));
7906
7907 -- Protected the call against abort
7908
7909 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7910 end if;
7911
7912 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param);
7913
7914 -- The result is the new block
7915
7916 Rewrite (N_Orig,
7917 Make_Block_Statement (Loc,
7918 Declarations => Decls,
7919 Handled_Statement_Sequence =>
7920 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7921
7922 Analyze (N_Orig);
7923 end Expand_N_Asynchronous_Select;
7924
7925 -------------------------------------
7926 -- Expand_N_Conditional_Entry_Call --
7927 -------------------------------------
7928
7929 -- The conditional task entry call is converted to a call to
7930 -- Task_Entry_Call:
7931
7932 -- declare
7933 -- B : Boolean;
7934 -- P : parms := (parm, parm, parm);
7935
7936 -- begin
7937 -- Task_Entry_Call
7938 -- (<acceptor-task>, -- Acceptor
7939 -- <entry-index>, -- E
7940 -- P'Address, -- Uninterpreted_Data
7941 -- Conditional_Call, -- Mode
7942 -- B); -- Rendezvous_Successful
7943 -- parm := P.param;
7944 -- parm := P.param;
7945 -- ...
7946 -- if B then
7947 -- normal-statements
7948 -- else
7949 -- else-statements
7950 -- end if;
7951 -- end;
7952
7953 -- For a description of the use of P and the assignments after the call,
7954 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the
7955 -- conditional entry call has already been expanded (by the Expand_N_Entry
7956 -- _Call_Statement procedure) as follows:
7957
7958 -- declare
7959 -- P : parms := (parm, parm, parm);
7960 -- begin
7961 -- ... info for in-out parameters
7962 -- Call_Simple (acceptor-task, entry-index, P'Address);
7963 -- parm := P.param;
7964 -- parm := P.param;
7965 -- ...
7966 -- end;
7967
7968 -- so the task at hand is to convert the latter expansion into the former
7969
7970 -- The conditional protected entry call is converted to a call to
7971 -- Protected_Entry_Call:
7972
7973 -- declare
7974 -- P : parms := (parm, parm, parm);
7975 -- Bnn : Communications_Block;
7976
7977 -- begin
7978 -- Protected_Entry_Call
7979 -- (po._object'Access, -- Object
7980 -- <entry index>, -- E
7981 -- P'Address, -- Uninterpreted_Data
7982 -- Conditional_Call, -- Mode
7983 -- Bnn); -- Block
7984 -- parm := P.param;
7985 -- parm := P.param;
7986 -- ...
7987 -- if Cancelled (Bnn) then
7988 -- else-statements
7989 -- else
7990 -- normal-statements
7991 -- end if;
7992 -- end;
7993
7994 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted
7995 -- into:
7996
7997 -- declare
7998 -- B : Boolean := False;
7999 -- C : Ada.Tags.Prim_Op_Kind;
8000 -- K : Ada.Tags.Tagged_Kind :=
8001 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
8002 -- P : Parameters := (Param1 .. ParamN);
8003 -- S : Integer;
8004
8005 -- begin
8006 -- if K = Ada.Tags.TK_Limited_Tagged
8007 -- or else K = Ada.Tags.TK_Tagged
8008 -- then
8009 -- <dispatching-call>;
8010 -- <triggering-statements>
8011
8012 -- else
8013 -- S :=
8014 -- Ada.Tags.Get_Offset_Index
8015 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
8016
8017 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
8018
8019 -- if C = POK_Protected_Entry
8020 -- or else C = POK_Task_Entry
8021 -- then
8022 -- Param1 := P.Param1;
8023 -- ...
8024 -- ParamN := P.ParamN;
8025 -- end if;
8026
8027 -- if B then
8028 -- if C = POK_Procedure
8029 -- or else C = POK_Protected_Procedure
8030 -- or else C = POK_Task_Procedure
8031 -- then
8032 -- <dispatching-call>;
8033 -- end if;
8034
8035 -- <triggering-statements>
8036 -- else
8037 -- <else-statements>
8038 -- end if;
8039 -- end if;
8040 -- end;
8041
8042 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is
8043 Loc : constant Source_Ptr := Sloc (N);
8044 Alt : constant Node_Id := Entry_Call_Alternative (N);
8045 Blk : Node_Id := Entry_Call_Statement (Alt);
8046
8047 Actuals : List_Id;
8048 Blk_Typ : Entity_Id;
8049 Call : Node_Id;
8050 Call_Ent : Entity_Id;
8051 Conc_Typ_Stmts : List_Id;
8052 Decl : Node_Id;
8053 Decls : List_Id;
8054 Formals : List_Id;
8055 Lim_Typ_Stmts : List_Id;
8056 N_Stats : List_Id;
8057 Obj : Entity_Id;
8058 Param : Node_Id;
8059 Params : List_Id;
8060 Stmt : Node_Id;
8061 Stmts : List_Id;
8062 Transient_Blk : Node_Id;
8063 Unpack : List_Id;
8064
8065 B : Entity_Id; -- Call status flag
8066 C : Entity_Id; -- Call kind
8067 K : Entity_Id; -- Tagged kind
8068 P : Entity_Id; -- Parameter block
8069 S : Entity_Id; -- Primitive operation slot
8070
8071 begin
8072 Process_Statements_For_Controlled_Objects (N);
8073
8074 if Ada_Version >= Ada_2005
8075 and then Nkind (Blk) = N_Procedure_Call_Statement
8076 then
8077 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals);
8078
8079 Decls := New_List;
8080 Stmts := New_List;
8081
8082 -- Call status flag processing, generate:
8083 -- B : Boolean := False;
8084
8085 B := Build_B (Loc, Decls);
8086
8087 -- Call kind processing, generate:
8088 -- C : Ada.Tags.Prim_Op_Kind;
8089
8090 C := Build_C (Loc, Decls);
8091
8092 -- Tagged kind processing, generate:
8093 -- K : Ada.Tags.Tagged_Kind :=
8094 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
8095
8096 K := Build_K (Loc, Decls, Obj);
8097
8098 -- Parameter block processing
8099
8100 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
8101 P := Parameter_Block_Pack
8102 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
8103
8104 -- Dispatch table slot processing, generate:
8105 -- S : Integer;
8106
8107 S := Build_S (Loc, Decls);
8108
8109 -- Generate:
8110 -- S := Ada.Tags.Get_Offset_Index
8111 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
8112
8113 Conc_Typ_Stmts :=
8114 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
8115
8116 -- Generate:
8117 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B);
8118
8119 Append_To (Conc_Typ_Stmts,
8120 Make_Procedure_Call_Statement (Loc,
8121 Name =>
8122 New_Occurrence_Of (
8123 Find_Prim_Op (Etype (Etype (Obj)),
8124 Name_uDisp_Conditional_Select),
8125 Loc),
8126 Parameter_Associations =>
8127 New_List (
8128 New_Copy_Tree (Obj), -- <object>
8129 New_Occurrence_Of (S, Loc), -- S
8130 Make_Attribute_Reference (Loc, -- P'Address
8131 Prefix => New_Occurrence_Of (P, Loc),
8132 Attribute_Name => Name_Address),
8133 New_Occurrence_Of (C, Loc), -- C
8134 New_Occurrence_Of (B, Loc)))); -- B
8135
8136 -- Generate:
8137 -- if C = POK_Protected_Entry
8138 -- or else C = POK_Task_Entry
8139 -- then
8140 -- Param1 := P.Param1;
8141 -- ...
8142 -- ParamN := P.ParamN;
8143 -- end if;
8144
8145 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
8146
8147 -- Generate the if statement only when the packed parameters need
8148 -- explicit assignments to their corresponding actuals.
8149
8150 if Present (Unpack) then
8151 Append_To (Conc_Typ_Stmts,
8152 Make_Implicit_If_Statement (N,
8153 Condition =>
8154 Make_Or_Else (Loc,
8155 Left_Opnd =>
8156 Make_Op_Eq (Loc,
8157 Left_Opnd =>
8158 New_Occurrence_Of (C, Loc),
8159 Right_Opnd =>
8160 New_Occurrence_Of (RTE (
8161 RE_POK_Protected_Entry), Loc)),
8162
8163 Right_Opnd =>
8164 Make_Op_Eq (Loc,
8165 Left_Opnd =>
8166 New_Occurrence_Of (C, Loc),
8167 Right_Opnd =>
8168 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
8169
8170 Then_Statements => Unpack));
8171 end if;
8172
8173 -- Generate:
8174 -- if B then
8175 -- if C = POK_Procedure
8176 -- or else C = POK_Protected_Procedure
8177 -- or else C = POK_Task_Procedure
8178 -- then
8179 -- <dispatching-call>
8180 -- end if;
8181 -- <normal-statements>
8182 -- else
8183 -- <else-statements>
8184 -- end if;
8185
8186 N_Stats := New_Copy_List_Tree (Statements (Alt));
8187
8188 Prepend_To (N_Stats,
8189 Make_Implicit_If_Statement (N,
8190 Condition =>
8191 Make_Or_Else (Loc,
8192 Left_Opnd =>
8193 Make_Op_Eq (Loc,
8194 Left_Opnd =>
8195 New_Occurrence_Of (C, Loc),
8196 Right_Opnd =>
8197 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)),
8198
8199 Right_Opnd =>
8200 Make_Or_Else (Loc,
8201 Left_Opnd =>
8202 Make_Op_Eq (Loc,
8203 Left_Opnd =>
8204 New_Occurrence_Of (C, Loc),
8205 Right_Opnd =>
8206 New_Occurrence_Of (RTE (
8207 RE_POK_Protected_Procedure), Loc)),
8208
8209 Right_Opnd =>
8210 Make_Op_Eq (Loc,
8211 Left_Opnd =>
8212 New_Occurrence_Of (C, Loc),
8213 Right_Opnd =>
8214 New_Occurrence_Of (RTE (
8215 RE_POK_Task_Procedure), Loc)))),
8216
8217 Then_Statements =>
8218 New_List (Blk)));
8219
8220 Append_To (Conc_Typ_Stmts,
8221 Make_Implicit_If_Statement (N,
8222 Condition => New_Occurrence_Of (B, Loc),
8223 Then_Statements => N_Stats,
8224 Else_Statements => Else_Statements (N)));
8225
8226 -- Generate:
8227 -- <dispatching-call>;
8228 -- <triggering-statements>
8229
8230 Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt));
8231 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
8232
8233 -- Generate:
8234 -- if K = Ada.Tags.TK_Limited_Tagged
8235 -- or else K = Ada.Tags.TK_Tagged
8236 -- then
8237 -- Lim_Typ_Stmts
8238 -- else
8239 -- Conc_Typ_Stmts
8240 -- end if;
8241
8242 Append_To (Stmts,
8243 Make_Implicit_If_Statement (N,
8244 Condition => Build_Dispatching_Tag_Check (K, N),
8245 Then_Statements => Lim_Typ_Stmts,
8246 Else_Statements => Conc_Typ_Stmts));
8247
8248 Rewrite (N,
8249 Make_Block_Statement (Loc,
8250 Declarations =>
8251 Decls,
8252 Handled_Statement_Sequence =>
8253 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
8254
8255 -- As described above, the entry alternative is transformed into a
8256 -- block that contains the gnulli call, and possibly assignment
8257 -- statements for in-out parameters. The gnulli call may itself be
8258 -- rewritten into a transient block if some unconstrained parameters
8259 -- require it. We need to retrieve the call to complete its parameter
8260 -- list.
8261
8262 else
8263 Transient_Blk :=
8264 First_Real_Statement (Handled_Statement_Sequence (Blk));
8265
8266 if Present (Transient_Blk)
8267 and then Nkind (Transient_Blk) = N_Block_Statement
8268 then
8269 Blk := Transient_Blk;
8270 end if;
8271
8272 Stmts := Statements (Handled_Statement_Sequence (Blk));
8273 Stmt := First (Stmts);
8274 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
8275 Next (Stmt);
8276 end loop;
8277
8278 Call := Stmt;
8279 Params := Parameter_Associations (Call);
8280
8281 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then
8282
8283 -- Substitute Conditional_Entry_Call for Simple_Call parameter
8284
8285 Param := First (Params);
8286 while Present (Param)
8287 and then not Is_RTE (Etype (Param), RE_Call_Modes)
8288 loop
8289 Next (Param);
8290 end loop;
8291
8292 pragma Assert (Present (Param));
8293 Rewrite (Param,
8294 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc));
8295
8296 Analyze (Param);
8297
8298 -- Find the Communication_Block parameter for the call to the
8299 -- Cancelled function.
8300
8301 Decl := First (Declarations (Blk));
8302 while Present (Decl)
8303 and then not Is_RTE (Etype (Object_Definition (Decl)),
8304 RE_Communication_Block)
8305 loop
8306 Next (Decl);
8307 end loop;
8308
8309 -- Add an if statement to execute the else part if the call
8310 -- does not succeed (as indicated by the Cancelled predicate).
8311
8312 Append_To (Stmts,
8313 Make_Implicit_If_Statement (N,
8314 Condition => Make_Function_Call (Loc,
8315 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc),
8316 Parameter_Associations => New_List (
8317 New_Occurrence_Of (Defining_Identifier (Decl), Loc))),
8318 Then_Statements => Else_Statements (N),
8319 Else_Statements => Statements (Alt)));
8320
8321 else
8322 B := Make_Defining_Identifier (Loc, Name_uB);
8323
8324 -- Insert declaration of B in declarations of existing block
8325
8326 if No (Declarations (Blk)) then
8327 Set_Declarations (Blk, New_List);
8328 end if;
8329
8330 Prepend_To (Declarations (Blk),
8331 Make_Object_Declaration (Loc,
8332 Defining_Identifier => B,
8333 Object_Definition =>
8334 New_Occurrence_Of (Standard_Boolean, Loc)));
8335
8336 -- Create new call statement
8337
8338 Append_To (Params,
8339 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc));
8340 Append_To (Params, New_Occurrence_Of (B, Loc));
8341
8342 Rewrite (Call,
8343 Make_Procedure_Call_Statement (Loc,
8344 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc),
8345 Parameter_Associations => Params));
8346
8347 -- Construct statement sequence for new block
8348
8349 Append_To (Stmts,
8350 Make_Implicit_If_Statement (N,
8351 Condition => New_Occurrence_Of (B, Loc),
8352 Then_Statements => Statements (Alt),
8353 Else_Statements => Else_Statements (N)));
8354 end if;
8355
8356 -- The result is the new block
8357
8358 Rewrite (N,
8359 Make_Block_Statement (Loc,
8360 Declarations => Declarations (Blk),
8361 Handled_Statement_Sequence =>
8362 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
8363 end if;
8364
8365 Analyze (N);
8366 end Expand_N_Conditional_Entry_Call;
8367
8368 ---------------------------------------
8369 -- Expand_N_Delay_Relative_Statement --
8370 ---------------------------------------
8371
8372 -- Delay statement is implemented as a procedure call to Delay_For
8373 -- defined in Ada.Calendar.Delays in order to reduce the overhead of
8374 -- simple delays imposed by the use of Protected Objects.
8375
8376 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
8377 Loc : constant Source_Ptr := Sloc (N);
8378 begin
8379 Rewrite (N,
8380 Make_Procedure_Call_Statement (Loc,
8381 Name => New_Occurrence_Of (RTE (RO_CA_Delay_For), Loc),
8382 Parameter_Associations => New_List (Expression (N))));
8383 Analyze (N);
8384 end Expand_N_Delay_Relative_Statement;
8385
8386 ------------------------------------
8387 -- Expand_N_Delay_Until_Statement --
8388 ------------------------------------
8389
8390 -- Delay Until statement is implemented as a procedure call to
8391 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays.
8392
8393 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is
8394 Loc : constant Source_Ptr := Sloc (N);
8395 Typ : Entity_Id;
8396
8397 begin
8398 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then
8399 Typ := RTE (RO_CA_Delay_Until);
8400 else
8401 Typ := RTE (RO_RT_Delay_Until);
8402 end if;
8403
8404 Rewrite (N,
8405 Make_Procedure_Call_Statement (Loc,
8406 Name => New_Occurrence_Of (Typ, Loc),
8407 Parameter_Associations => New_List (Expression (N))));
8408
8409 Analyze (N);
8410 end Expand_N_Delay_Until_Statement;
8411
8412 -------------------------
8413 -- Expand_N_Entry_Body --
8414 -------------------------
8415
8416 procedure Expand_N_Entry_Body (N : Node_Id) is
8417 begin
8418 -- Associate discriminals with the next protected operation body to be
8419 -- expanded.
8420
8421 if Present (Next_Protected_Operation (N)) then
8422 Set_Discriminals (Parent (Current_Scope));
8423 end if;
8424 end Expand_N_Entry_Body;
8425
8426 -----------------------------------
8427 -- Expand_N_Entry_Call_Statement --
8428 -----------------------------------
8429
8430 -- An entry call is expanded into GNARLI calls to implement a simple entry
8431 -- call (see Build_Simple_Entry_Call).
8432
8433 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is
8434 Concval : Node_Id;
8435 Ename : Node_Id;
8436 Index : Node_Id;
8437
8438 begin
8439 if No_Run_Time_Mode then
8440 Error_Msg_CRT ("entry call", N);
8441 return;
8442 end if;
8443
8444 -- If this entry call is part of an asynchronous select, don't expand it
8445 -- here; it will be expanded with the select statement. Don't expand
8446 -- timed entry calls either, as they are translated into asynchronous
8447 -- entry calls.
8448
8449 -- ??? This whole approach is questionable; it may be better to go back
8450 -- to allowing the expansion to take place and then attempting to fix it
8451 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out
8452 -- whether the expanded call is on a task or protected entry.
8453
8454 if (Nkind (Parent (N)) /= N_Triggering_Alternative
8455 or else N /= Triggering_Statement (Parent (N)))
8456 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative
8457 or else N /= Entry_Call_Statement (Parent (N))
8458 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call)
8459 then
8460 Extract_Entry (N, Concval, Ename, Index);
8461 Build_Simple_Entry_Call (N, Concval, Ename, Index);
8462 end if;
8463 end Expand_N_Entry_Call_Statement;
8464
8465 --------------------------------
8466 -- Expand_N_Entry_Declaration --
8467 --------------------------------
8468
8469 -- If there are parameters, then first, each of the formals is marked by
8470 -- setting Is_Entry_Formal. Next a record type is built which is used to
8471 -- hold the parameter values. The name of this record type is entryP where
8472 -- entry is the name of the entry, with an additional corresponding access
8473 -- type called entryPA. The record type has matching components for each
8474 -- formal (the component names are the same as the formal names). For
8475 -- elementary types, the component type matches the formal type. For
8476 -- composite types, an access type is declared (with the name formalA)
8477 -- which designates the formal type, and the type of the component is this
8478 -- access type. Finally the Entry_Component of each formal is set to
8479 -- reference the corresponding record component.
8480
8481 procedure Expand_N_Entry_Declaration (N : Node_Id) is
8482 Loc : constant Source_Ptr := Sloc (N);
8483 Entry_Ent : constant Entity_Id := Defining_Identifier (N);
8484 Components : List_Id;
8485 Formal : Node_Id;
8486 Ftype : Entity_Id;
8487 Last_Decl : Node_Id;
8488 Component : Entity_Id;
8489 Ctype : Entity_Id;
8490 Decl : Node_Id;
8491 Rec_Ent : Entity_Id;
8492 Acc_Ent : Entity_Id;
8493
8494 begin
8495 Formal := First_Formal (Entry_Ent);
8496 Last_Decl := N;
8497
8498 -- Most processing is done only if parameters are present
8499
8500 if Present (Formal) then
8501 Components := New_List;
8502
8503 -- Loop through formals
8504
8505 while Present (Formal) loop
8506 Set_Is_Entry_Formal (Formal);
8507 Component :=
8508 Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
8509 Set_Entry_Component (Formal, Component);
8510 Set_Entry_Formal (Component, Formal);
8511 Ftype := Etype (Formal);
8512
8513 -- Declare new access type and then append
8514
8515 Ctype := Make_Temporary (Loc, 'A');
8516 Set_Is_Param_Block_Component_Type (Ctype);
8517
8518 Decl :=
8519 Make_Full_Type_Declaration (Loc,
8520 Defining_Identifier => Ctype,
8521 Type_Definition =>
8522 Make_Access_To_Object_Definition (Loc,
8523 All_Present => True,
8524 Constant_Present => Ekind (Formal) = E_In_Parameter,
8525 Subtype_Indication => New_Occurrence_Of (Ftype, Loc)));
8526
8527 Insert_After (Last_Decl, Decl);
8528 Last_Decl := Decl;
8529
8530 Append_To (Components,
8531 Make_Component_Declaration (Loc,
8532 Defining_Identifier => Component,
8533 Component_Definition =>
8534 Make_Component_Definition (Loc,
8535 Aliased_Present => False,
8536 Subtype_Indication => New_Occurrence_Of (Ctype, Loc))));
8537
8538 Next_Formal_With_Extras (Formal);
8539 end loop;
8540
8541 -- Create the Entry_Parameter_Record declaration
8542
8543 Rec_Ent := Make_Temporary (Loc, 'P');
8544
8545 Decl :=
8546 Make_Full_Type_Declaration (Loc,
8547 Defining_Identifier => Rec_Ent,
8548 Type_Definition =>
8549 Make_Record_Definition (Loc,
8550 Component_List =>
8551 Make_Component_List (Loc,
8552 Component_Items => Components)));
8553
8554 Insert_After (Last_Decl, Decl);
8555 Last_Decl := Decl;
8556
8557 -- Construct and link in the corresponding access type
8558
8559 Acc_Ent := Make_Temporary (Loc, 'A');
8560
8561 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent);
8562
8563 Decl :=
8564 Make_Full_Type_Declaration (Loc,
8565 Defining_Identifier => Acc_Ent,
8566 Type_Definition =>
8567 Make_Access_To_Object_Definition (Loc,
8568 All_Present => True,
8569 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc)));
8570
8571 Insert_After (Last_Decl, Decl);
8572 end if;
8573 end Expand_N_Entry_Declaration;
8574
8575 -----------------------------
8576 -- Expand_N_Protected_Body --
8577 -----------------------------
8578
8579 -- Protected bodies are expanded to the completion of the subprograms
8580 -- created for the corresponding protected type. These are a protected and
8581 -- unprotected version of each protected subprogram in the object, a
8582 -- function to calculate each entry barrier, and a procedure to execute the
8583 -- sequence of statements of each protected entry body. For example, for
8584 -- protected type ptype:
8585
8586 -- function entB
8587 -- (O : System.Address;
8588 -- E : Protected_Entry_Index)
8589 -- return Boolean
8590 -- is
8591 -- <discriminant renamings>
8592 -- <private object renamings>
8593 -- begin
8594 -- return <barrier expression>;
8595 -- end entB;
8596
8597 -- procedure pprocN (_object : in out poV;...) is
8598 -- <discriminant renamings>
8599 -- <private object renamings>
8600 -- begin
8601 -- <sequence of statements>
8602 -- end pprocN;
8603
8604 -- procedure pprocP (_object : in out poV;...) is
8605 -- procedure _clean is
8606 -- Pn : Boolean;
8607 -- begin
8608 -- ptypeS (_object, Pn);
8609 -- Unlock (_object._object'Access);
8610 -- Abort_Undefer.all;
8611 -- end _clean;
8612
8613 -- begin
8614 -- Abort_Defer.all;
8615 -- Lock (_object._object'Access);
8616 -- pprocN (_object;...);
8617 -- at end
8618 -- _clean;
8619 -- end pproc;
8620
8621 -- function pfuncN (_object : poV;...) return Return_Type is
8622 -- <discriminant renamings>
8623 -- <private object renamings>
8624 -- begin
8625 -- <sequence of statements>
8626 -- end pfuncN;
8627
8628 -- function pfuncP (_object : poV) return Return_Type is
8629 -- procedure _clean is
8630 -- begin
8631 -- Unlock (_object._object'Access);
8632 -- Abort_Undefer.all;
8633 -- end _clean;
8634
8635 -- begin
8636 -- Abort_Defer.all;
8637 -- Lock (_object._object'Access);
8638 -- return pfuncN (_object);
8639
8640 -- at end
8641 -- _clean;
8642 -- end pfunc;
8643
8644 -- procedure entE
8645 -- (O : System.Address;
8646 -- P : System.Address;
8647 -- E : Protected_Entry_Index)
8648 -- is
8649 -- <discriminant renamings>
8650 -- <private object renamings>
8651 -- type poVP is access poV;
8652 -- _Object : ptVP := ptVP!(O);
8653
8654 -- begin
8655 -- begin
8656 -- <statement sequence>
8657 -- Complete_Entry_Body (_Object._Object);
8658 -- exception
8659 -- when all others =>
8660 -- Exceptional_Complete_Entry_Body (
8661 -- _Object._Object, Get_GNAT_Exception);
8662 -- end;
8663 -- end entE;
8664
8665 -- The type poV is the record created for the protected type to hold
8666 -- the state of the protected object.
8667
8668 procedure Expand_N_Protected_Body (N : Node_Id) is
8669 Loc : constant Source_Ptr := Sloc (N);
8670 Pid : constant Entity_Id := Corresponding_Spec (N);
8671
8672 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid);
8673 -- This flag indicates whether the lock free implementation is active
8674
8675 Current_Node : Node_Id;
8676 Disp_Op_Body : Node_Id;
8677 New_Op_Body : Node_Id;
8678 Op_Body : Node_Id;
8679 Op_Id : Entity_Id;
8680
8681 function Build_Dispatching_Subprogram_Body
8682 (N : Node_Id;
8683 Pid : Node_Id;
8684 Prot_Bod : Node_Id) return Node_Id;
8685 -- Build a dispatching version of the protected subprogram body. The
8686 -- newly generated subprogram contains a call to the original protected
8687 -- body. The following code is generated:
8688 --
8689 -- function <protected-function-name> (Param1 .. ParamN) return
8690 -- <return-type> is
8691 -- begin
8692 -- return <protected-function-name>P (Param1 .. ParamN);
8693 -- end <protected-function-name>;
8694 --
8695 -- or
8696 --
8697 -- procedure <protected-procedure-name> (Param1 .. ParamN) is
8698 -- begin
8699 -- <protected-procedure-name>P (Param1 .. ParamN);
8700 -- end <protected-procedure-name>
8701
8702 ---------------------------------------
8703 -- Build_Dispatching_Subprogram_Body --
8704 ---------------------------------------
8705
8706 function Build_Dispatching_Subprogram_Body
8707 (N : Node_Id;
8708 Pid : Node_Id;
8709 Prot_Bod : Node_Id) return Node_Id
8710 is
8711 Loc : constant Source_Ptr := Sloc (N);
8712 Actuals : List_Id;
8713 Formal : Node_Id;
8714 Spec : Node_Id;
8715 Stmts : List_Id;
8716
8717 begin
8718 -- Generate a specification without a letter suffix in order to
8719 -- override an interface function or procedure.
8720
8721 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
8722
8723 -- The formal parameters become the actuals of the protected function
8724 -- or procedure call.
8725
8726 Actuals := New_List;
8727 Formal := First (Parameter_Specifications (Spec));
8728 while Present (Formal) loop
8729 Append_To (Actuals,
8730 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
8731 Next (Formal);
8732 end loop;
8733
8734 if Nkind (Spec) = N_Procedure_Specification then
8735 Stmts :=
8736 New_List (
8737 Make_Procedure_Call_Statement (Loc,
8738 Name =>
8739 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc),
8740 Parameter_Associations => Actuals));
8741
8742 else
8743 pragma Assert (Nkind (Spec) = N_Function_Specification);
8744
8745 Stmts :=
8746 New_List (
8747 Make_Simple_Return_Statement (Loc,
8748 Expression =>
8749 Make_Function_Call (Loc,
8750 Name =>
8751 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc),
8752 Parameter_Associations => Actuals)));
8753 end if;
8754
8755 return
8756 Make_Subprogram_Body (Loc,
8757 Declarations => Empty_List,
8758 Specification => Spec,
8759 Handled_Statement_Sequence =>
8760 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8761 end Build_Dispatching_Subprogram_Body;
8762
8763 -- Start of processing for Expand_N_Protected_Body
8764
8765 begin
8766 if No_Run_Time_Mode then
8767 Error_Msg_CRT ("protected body", N);
8768 return;
8769 end if;
8770
8771 -- This is the proper body corresponding to a stub. The declarations
8772 -- must be inserted at the point of the stub, which in turn is in the
8773 -- declarative part of the parent unit.
8774
8775 if Nkind (Parent (N)) = N_Subunit then
8776 Current_Node := Corresponding_Stub (Parent (N));
8777 else
8778 Current_Node := N;
8779 end if;
8780
8781 Op_Body := First (Declarations (N));
8782
8783 -- The protected body is replaced with the bodies of its
8784 -- protected operations, and the declarations for internal objects
8785 -- that may have been created for entry family bounds.
8786
8787 Rewrite (N, Make_Null_Statement (Sloc (N)));
8788 Analyze (N);
8789
8790 while Present (Op_Body) loop
8791 case Nkind (Op_Body) is
8792 when N_Subprogram_Declaration =>
8793 null;
8794
8795 when N_Subprogram_Body =>
8796
8797 -- Do not create bodies for eliminated operations
8798
8799 if not Is_Eliminated (Defining_Entity (Op_Body))
8800 and then not Is_Eliminated (Corresponding_Spec (Op_Body))
8801 then
8802 if Lock_Free_Active then
8803 New_Op_Body :=
8804 Build_Lock_Free_Unprotected_Subprogram_Body
8805 (Op_Body, Pid);
8806 else
8807 New_Op_Body :=
8808 Build_Unprotected_Subprogram_Body (Op_Body, Pid);
8809 end if;
8810
8811 Insert_After (Current_Node, New_Op_Body);
8812 Current_Node := New_Op_Body;
8813 Analyze (New_Op_Body);
8814
8815 -- Build the corresponding protected operation. It may
8816 -- appear that this is needed only if this is a visible
8817 -- operation of the type, or if it is an interrupt handler,
8818 -- and this was the strategy used previously in GNAT.
8819
8820 -- However, the operation may be exported through a 'Access
8821 -- to an external caller. This is the common idiom in code
8822 -- that uses the Ada 2005 Timing_Events package. As a result
8823 -- we need to produce the protected body for both visible
8824 -- and private operations, as well as operations that only
8825 -- have a body in the source, and for which we create a
8826 -- declaration in the protected body itself.
8827
8828 if Present (Corresponding_Spec (Op_Body)) then
8829 if Lock_Free_Active then
8830 New_Op_Body :=
8831 Build_Lock_Free_Protected_Subprogram_Body
8832 (Op_Body, Pid, Specification (New_Op_Body));
8833 else
8834 New_Op_Body :=
8835 Build_Protected_Subprogram_Body
8836 (Op_Body, Pid, Specification (New_Op_Body));
8837 end if;
8838
8839 Insert_After (Current_Node, New_Op_Body);
8840 Analyze (New_Op_Body);
8841
8842 Current_Node := New_Op_Body;
8843
8844 -- Generate an overriding primitive operation body for
8845 -- this subprogram if the protected type implements an
8846 -- interface.
8847
8848 if Ada_Version >= Ada_2005
8849 and then
8850 Present (Interfaces (Corresponding_Record_Type (Pid)))
8851 then
8852 Disp_Op_Body :=
8853 Build_Dispatching_Subprogram_Body
8854 (Op_Body, Pid, New_Op_Body);
8855
8856 Insert_After (Current_Node, Disp_Op_Body);
8857 Analyze (Disp_Op_Body);
8858
8859 Current_Node := Disp_Op_Body;
8860 end if;
8861 end if;
8862 end if;
8863
8864 when N_Entry_Body =>
8865 Op_Id := Defining_Identifier (Op_Body);
8866 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid);
8867
8868 Insert_After (Current_Node, New_Op_Body);
8869 Current_Node := New_Op_Body;
8870 Analyze (New_Op_Body);
8871
8872 when N_Implicit_Label_Declaration =>
8873 null;
8874
8875 when N_Itype_Reference =>
8876 Insert_After (Current_Node, New_Copy (Op_Body));
8877
8878 when N_Freeze_Entity =>
8879 New_Op_Body := New_Copy (Op_Body);
8880
8881 if Present (Entity (Op_Body))
8882 and then Freeze_Node (Entity (Op_Body)) = Op_Body
8883 then
8884 Set_Freeze_Node (Entity (Op_Body), New_Op_Body);
8885 end if;
8886
8887 Insert_After (Current_Node, New_Op_Body);
8888 Current_Node := New_Op_Body;
8889 Analyze (New_Op_Body);
8890
8891 when N_Pragma =>
8892 New_Op_Body := New_Copy (Op_Body);
8893 Insert_After (Current_Node, New_Op_Body);
8894 Current_Node := New_Op_Body;
8895 Analyze (New_Op_Body);
8896
8897 when N_Object_Declaration =>
8898 pragma Assert (not Comes_From_Source (Op_Body));
8899 New_Op_Body := New_Copy (Op_Body);
8900 Insert_After (Current_Node, New_Op_Body);
8901 Current_Node := New_Op_Body;
8902 Analyze (New_Op_Body);
8903
8904 when others =>
8905 raise Program_Error;
8906
8907 end case;
8908
8909 Next (Op_Body);
8910 end loop;
8911
8912 -- Finally, create the body of the function that maps an entry index
8913 -- into the corresponding body index, except when there is no entry, or
8914 -- in a Ravenscar-like profile.
8915
8916 if Corresponding_Runtime_Package (Pid) =
8917 System_Tasking_Protected_Objects_Entries
8918 then
8919 New_Op_Body := Build_Find_Body_Index (Pid);
8920 Insert_After (Current_Node, New_Op_Body);
8921 Current_Node := New_Op_Body;
8922 Analyze (New_Op_Body);
8923 end if;
8924
8925 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the
8926 -- protected body. At this point all wrapper specs have been created,
8927 -- frozen and included in the dispatch table for the protected type.
8928
8929 if Ada_Version >= Ada_2005 then
8930 Build_Wrapper_Bodies (Loc, Pid, Current_Node);
8931 end if;
8932 end Expand_N_Protected_Body;
8933
8934 -----------------------------------------
8935 -- Expand_N_Protected_Type_Declaration --
8936 -----------------------------------------
8937
8938 -- First we create a corresponding record type declaration used to
8939 -- represent values of this protected type.
8940 -- The general form of this type declaration is
8941
8942 -- type poV (discriminants) is record
8943 -- _Object : aliased <kind>Protection
8944 -- [(<entry count> [, <handler count>])];
8945 -- [entry_family : array (bounds) of Void;]
8946 -- <private data fields>
8947 -- end record;
8948
8949 -- The discriminants are present only if the corresponding protected type
8950 -- has discriminants, and they exactly mirror the protected type
8951 -- discriminants. The private data fields similarly mirror the private
8952 -- declarations of the protected type.
8953
8954 -- The Object field is always present. It contains RTS specific data used
8955 -- to control the protected object. It is declared as Aliased so that it
8956 -- can be passed as a pointer to the RTS. This allows the protected record
8957 -- to be referenced within RTS data structures. An appropriate Protection
8958 -- type and discriminant are generated.
8959
8960 -- The Service field is present for protected objects with entries. It
8961 -- contains sufficient information to allow the entry service procedure for
8962 -- this object to be called when the object is not known till runtime.
8963
8964 -- One entry_family component is present for each entry family in the
8965 -- task definition (see Expand_N_Task_Type_Declaration).
8966
8967 -- When a protected object is declared, an instance of the protected type
8968 -- value record is created. The elaboration of this declaration creates the
8969 -- correct bounds for the entry families, and also evaluates the priority
8970 -- expression if needed. The initialization routine for the protected type
8971 -- itself then calls Initialize_Protection with appropriate parameters to
8972 -- initialize the value of the Task_Id field. Install_Handlers may be also
8973 -- called if a pragma Attach_Handler applies.
8974
8975 -- Note: this record is passed to the subprograms created by the expansion
8976 -- of protected subprograms and entries. It is an in parameter to protected
8977 -- functions and an in out parameter to procedures and entry bodies. The
8978 -- Entity_Id for this created record type is placed in the
8979 -- Corresponding_Record_Type field of the associated protected type entity.
8980
8981 -- Next we create a procedure specifications for protected subprograms and
8982 -- entry bodies. For each protected subprograms two subprograms are
8983 -- created, an unprotected and a protected version. The unprotected version
8984 -- is called from within other operations of the same protected object.
8985
8986 -- We also build the call to register the procedure if a pragma
8987 -- Interrupt_Handler applies.
8988
8989 -- A single subprogram is created to service all entry bodies; it has an
8990 -- additional boolean out parameter indicating that the previous entry call
8991 -- made by the current task was serviced immediately, i.e. not by proxy.
8992 -- The O parameter contains a pointer to a record object of the type
8993 -- described above. An untyped interface is used here to allow this
8994 -- procedure to be called in places where the type of the object to be
8995 -- serviced is not known. This must be done, for example, when a call that
8996 -- may have been requeued is cancelled; the corresponding object must be
8997 -- serviced, but which object that is not known till runtime.
8998
8999 -- procedure ptypeS
9000 -- (O : System.Address; P : out Boolean);
9001 -- procedure pprocN (_object : in out poV);
9002 -- procedure pproc (_object : in out poV);
9003 -- function pfuncN (_object : poV);
9004 -- function pfunc (_object : poV);
9005 -- ...
9006
9007 -- Note that this must come after the record type declaration, since
9008 -- the specs refer to this type.
9009
9010 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
9011 Discr_Map : constant Elist_Id := New_Elmt_List;
9012 Loc : constant Source_Ptr := Sloc (N);
9013 Prot_Typ : constant Entity_Id := Defining_Identifier (N);
9014
9015 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ);
9016 -- This flag indicates whether the lock free implementation is active
9017
9018 Pdef : constant Node_Id := Protected_Definition (N);
9019 -- This contains two lists; one for visible and one for private decls
9020
9021 Body_Arr : Node_Id;
9022 Body_Id : Entity_Id;
9023 Cdecls : List_Id;
9024 Comp : Node_Id;
9025 Current_Node : Node_Id := N;
9026 E_Count : Int;
9027 Entries_Aggr : Node_Id;
9028 New_Priv : Node_Id;
9029 Object_Comp : Node_Id;
9030 Priv : Node_Id;
9031 Rec_Decl : Node_Id;
9032
9033 procedure Check_Inlining (Subp : Entity_Id);
9034 -- If the original operation has a pragma Inline, propagate the flag
9035 -- to the internal body, for possible inlining later on. The source
9036 -- operation is invisible to the back-end and is never actually called.
9037
9038 function Discriminated_Size (Comp : Entity_Id) return Boolean;
9039 -- If a component size is not static then a warning will be emitted
9040 -- in Ravenscar or other restricted contexts. When a component is non-
9041 -- static because of a discriminant constraint we can specialize the
9042 -- warning by mentioning discriminants explicitly.
9043
9044 procedure Expand_Entry_Declaration (Decl : Node_Id);
9045 -- Create the entry barrier and the procedure body for entry declaration
9046 -- Decl. All generated subprograms are added to Entry_Bodies_Array.
9047
9048 function Static_Component_Size (Comp : Entity_Id) return Boolean;
9049 -- When compiling under the Ravenscar profile, private components must
9050 -- have a static size, or else a protected object will require heap
9051 -- allocation, violating the corresponding restriction. It is preferable
9052 -- to make this check here, because it provides a better error message
9053 -- than the back-end, which refers to the object as a whole.
9054
9055 procedure Register_Handler;
9056 -- For a protected operation that is an interrupt handler, add the
9057 -- freeze action that will register it as such.
9058
9059 --------------------
9060 -- Check_Inlining --
9061 --------------------
9062
9063 procedure Check_Inlining (Subp : Entity_Id) is
9064 begin
9065 if Is_Inlined (Subp) then
9066 Set_Is_Inlined (Protected_Body_Subprogram (Subp));
9067 Set_Is_Inlined (Subp, False);
9068 end if;
9069 end Check_Inlining;
9070
9071 ------------------------
9072 -- Discriminated_Size --
9073 ------------------------
9074
9075 function Discriminated_Size (Comp : Entity_Id) return Boolean is
9076 Typ : constant Entity_Id := Etype (Comp);
9077 Index : Node_Id;
9078
9079 function Non_Static_Bound (Bound : Node_Id) return Boolean;
9080 -- Check whether the bound of an index is non-static and does denote
9081 -- a discriminant, in which case any protected object of the type
9082 -- will have a non-static size.
9083
9084 ----------------------
9085 -- Non_Static_Bound --
9086 ----------------------
9087
9088 function Non_Static_Bound (Bound : Node_Id) return Boolean is
9089 begin
9090 if Is_OK_Static_Expression (Bound) then
9091 return False;
9092
9093 elsif Is_Entity_Name (Bound)
9094 and then Present (Discriminal_Link (Entity (Bound)))
9095 then
9096 return False;
9097
9098 else
9099 return True;
9100 end if;
9101 end Non_Static_Bound;
9102
9103 -- Start of processing for Discriminated_Size
9104
9105 begin
9106 if not Is_Array_Type (Typ) then
9107 return False;
9108 end if;
9109
9110 if Ekind (Typ) = E_Array_Subtype then
9111 Index := First_Index (Typ);
9112 while Present (Index) loop
9113 if Non_Static_Bound (Low_Bound (Index))
9114 or else Non_Static_Bound (High_Bound (Index))
9115 then
9116 return False;
9117 end if;
9118
9119 Next_Index (Index);
9120 end loop;
9121
9122 return True;
9123 end if;
9124
9125 return False;
9126 end Discriminated_Size;
9127
9128 ---------------------------
9129 -- Static_Component_Size --
9130 ---------------------------
9131
9132 function Static_Component_Size (Comp : Entity_Id) return Boolean is
9133 Typ : constant Entity_Id := Etype (Comp);
9134 C : Entity_Id;
9135
9136 begin
9137 if Is_Scalar_Type (Typ) then
9138 return True;
9139
9140 elsif Is_Array_Type (Typ) then
9141 return Compile_Time_Known_Bounds (Typ);
9142
9143 elsif Is_Record_Type (Typ) then
9144 C := First_Component (Typ);
9145 while Present (C) loop
9146 if not Static_Component_Size (C) then
9147 return False;
9148 end if;
9149
9150 Next_Component (C);
9151 end loop;
9152
9153 return True;
9154
9155 -- Any other type will be checked by the back-end
9156
9157 else
9158 return True;
9159 end if;
9160 end Static_Component_Size;
9161
9162 ------------------------------
9163 -- Expand_Entry_Declaration --
9164 ------------------------------
9165
9166 procedure Expand_Entry_Declaration (Decl : Node_Id) is
9167 Ent_Id : constant Entity_Id := Defining_Entity (Decl);
9168 Bar_Id : Entity_Id;
9169 Bod_Id : Entity_Id;
9170 Subp : Node_Id;
9171
9172 begin
9173 E_Count := E_Count + 1;
9174
9175 -- Create the protected body subprogram
9176
9177 Bod_Id :=
9178 Make_Defining_Identifier (Loc,
9179 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E'));
9180 Set_Protected_Body_Subprogram (Ent_Id, Bod_Id);
9181
9182 Subp :=
9183 Make_Subprogram_Declaration (Loc,
9184 Specification =>
9185 Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id));
9186
9187 Insert_After (Current_Node, Subp);
9188 Current_Node := Subp;
9189
9190 Analyze (Subp);
9191
9192 -- Build a wrapper procedure to handle contract cases, preconditions,
9193 -- and postconditions.
9194
9195 Build_Contract_Wrapper (Ent_Id, N);
9196
9197 -- Create the barrier function
9198
9199 Bar_Id :=
9200 Make_Defining_Identifier (Loc,
9201 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B'));
9202 Set_Barrier_Function (Ent_Id, Bar_Id);
9203
9204 Subp :=
9205 Make_Subprogram_Declaration (Loc,
9206 Specification =>
9207 Build_Barrier_Function_Specification (Loc, Bar_Id));
9208 Set_Is_Entry_Barrier_Function (Subp);
9209
9210 Insert_After (Current_Node, Subp);
9211 Current_Node := Subp;
9212
9213 Analyze (Subp);
9214
9215 Set_Protected_Body_Subprogram (Bar_Id, Bar_Id);
9216 Set_Scope (Bar_Id, Scope (Ent_Id));
9217
9218 -- Collect pointers to the protected subprogram and the barrier
9219 -- of the current entry, for insertion into Entry_Bodies_Array.
9220
9221 Append_To (Expressions (Entries_Aggr),
9222 Make_Aggregate (Loc,
9223 Expressions => New_List (
9224 Make_Attribute_Reference (Loc,
9225 Prefix => New_Occurrence_Of (Bar_Id, Loc),
9226 Attribute_Name => Name_Unrestricted_Access),
9227 Make_Attribute_Reference (Loc,
9228 Prefix => New_Occurrence_Of (Bod_Id, Loc),
9229 Attribute_Name => Name_Unrestricted_Access))));
9230 end Expand_Entry_Declaration;
9231
9232 ----------------------
9233 -- Register_Handler --
9234 ----------------------
9235
9236 procedure Register_Handler is
9237
9238 -- All semantic checks already done in Sem_Prag
9239
9240 Prot_Proc : constant Entity_Id :=
9241 Defining_Unit_Name (Specification (Current_Node));
9242
9243 Proc_Address : constant Node_Id :=
9244 Make_Attribute_Reference (Loc,
9245 Prefix =>
9246 New_Occurrence_Of (Prot_Proc, Loc),
9247 Attribute_Name => Name_Address);
9248
9249 RTS_Call : constant Entity_Id :=
9250 Make_Procedure_Call_Statement (Loc,
9251 Name =>
9252 New_Occurrence_Of
9253 (RTE (RE_Register_Interrupt_Handler), Loc),
9254 Parameter_Associations => New_List (Proc_Address));
9255 begin
9256 Append_Freeze_Action (Prot_Proc, RTS_Call);
9257 end Register_Handler;
9258
9259 -- Local variables
9260
9261 Sub : Node_Id;
9262
9263 -- Start of processing for Expand_N_Protected_Type_Declaration
9264
9265 begin
9266 if Present (Corresponding_Record_Type (Prot_Typ)) then
9267 return;
9268 else
9269 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc);
9270 end if;
9271
9272 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl)));
9273
9274 Qualify_Entity_Names (N);
9275
9276 -- If the type has discriminants, their occurrences in the declaration
9277 -- have been replaced by the corresponding discriminals. For components
9278 -- that are constrained by discriminants, their homologues in the
9279 -- corresponding record type must refer to the discriminants of that
9280 -- record, so we must apply a new renaming to subtypes_indications:
9281
9282 -- protected discriminant => discriminal => record discriminant
9283
9284 -- This replacement is not applied to default expressions, for which
9285 -- the discriminal is correct.
9286
9287 if Has_Discriminants (Prot_Typ) then
9288 declare
9289 Disc : Entity_Id;
9290 Decl : Node_Id;
9291
9292 begin
9293 Disc := First_Discriminant (Prot_Typ);
9294 Decl := First (Discriminant_Specifications (Rec_Decl));
9295 while Present (Disc) loop
9296 Append_Elmt (Discriminal (Disc), Discr_Map);
9297 Append_Elmt (Defining_Identifier (Decl), Discr_Map);
9298 Next_Discriminant (Disc);
9299 Next (Decl);
9300 end loop;
9301 end;
9302 end if;
9303
9304 -- Fill in the component declarations
9305
9306 -- Add components for entry families. For each entry family, create an
9307 -- anonymous type declaration with the same size, and analyze the type.
9308
9309 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ);
9310
9311 pragma Assert (Present (Pdef));
9312
9313 -- Add private field components
9314
9315 if Present (Private_Declarations (Pdef)) then
9316 Priv := First (Private_Declarations (Pdef));
9317 while Present (Priv) loop
9318 if Nkind (Priv) = N_Component_Declaration then
9319 if not Static_Component_Size (Defining_Identifier (Priv)) then
9320
9321 -- When compiling for a restricted profile, the private
9322 -- components must have a static size. If not, this is an
9323 -- error for a single protected declaration, and rates a
9324 -- warning on a protected type declaration.
9325
9326 if not Comes_From_Source (Prot_Typ) then
9327
9328 -- It's ok to be checking this restriction at expansion
9329 -- time, because this is only for the restricted profile,
9330 -- which is not subject to strict RM conformance, so it
9331 -- is OK to miss this check in -gnatc mode.
9332
9333 Check_Restriction (No_Implicit_Heap_Allocations, Priv);
9334 Check_Restriction
9335 (No_Implicit_Protected_Object_Allocations, Priv);
9336
9337 elsif Restriction_Active (No_Implicit_Heap_Allocations) then
9338 if not Discriminated_Size (Defining_Identifier (Priv))
9339 then
9340 -- Any object of the type will be non-static.
9341
9342 Error_Msg_N ("component has non-static size??", Priv);
9343 Error_Msg_NE
9344 ("\creation of protected object of type& will "
9345 & "violate restriction "
9346 & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ);
9347 else
9348
9349 -- Object will be non-static if discriminants are.
9350
9351 Error_Msg_NE
9352 ("creation of protected object of type& with "
9353 & "non-static discriminants will violate"
9354 & " restriction No_Implicit_Heap_Allocations??",
9355 Priv, Prot_Typ);
9356 end if;
9357
9358 -- Likewise for No_Implicit_Protected_Object_Allocations
9359
9360 elsif Restriction_Active
9361 (No_Implicit_Protected_Object_Allocations)
9362 then
9363 if not Discriminated_Size (Defining_Identifier (Priv))
9364 then
9365 -- Any object of the type will be non-static.
9366
9367 Error_Msg_N ("component has non-static size??", Priv);
9368 Error_Msg_NE
9369 ("\creation of protected object of type& will "
9370 & "violate restriction "
9371 & "No_Implicit_Protected_Object_Allocations??",
9372 Priv, Prot_Typ);
9373 else
9374 -- Object will be non-static if discriminants are.
9375
9376 Error_Msg_NE
9377 ("creation of protected object of type& with "
9378 & "non-static discriminants will violate "
9379 & "restriction "
9380 & "No_Implicit_Protected_Object_Allocations??",
9381 Priv, Prot_Typ);
9382 end if;
9383 end if;
9384 end if;
9385
9386 -- The component definition consists of a subtype indication,
9387 -- or (in Ada 2005) an access definition. Make a copy of the
9388 -- proper definition.
9389
9390 declare
9391 Old_Comp : constant Node_Id := Component_Definition (Priv);
9392 Oent : constant Entity_Id := Defining_Identifier (Priv);
9393 Nent : constant Entity_Id :=
9394 Make_Defining_Identifier (Sloc (Oent),
9395 Chars => Chars (Oent));
9396 New_Comp : Node_Id;
9397
9398 begin
9399 if Present (Subtype_Indication (Old_Comp)) then
9400 New_Comp :=
9401 Make_Component_Definition (Sloc (Oent),
9402 Aliased_Present => False,
9403 Subtype_Indication =>
9404 New_Copy_Tree
9405 (Subtype_Indication (Old_Comp), Discr_Map));
9406 else
9407 New_Comp :=
9408 Make_Component_Definition (Sloc (Oent),
9409 Aliased_Present => False,
9410 Access_Definition =>
9411 New_Copy_Tree
9412 (Access_Definition (Old_Comp), Discr_Map));
9413 end if;
9414
9415 New_Priv :=
9416 Make_Component_Declaration (Loc,
9417 Defining_Identifier => Nent,
9418 Component_Definition => New_Comp,
9419 Expression => Expression (Priv));
9420
9421 Set_Has_Per_Object_Constraint (Nent,
9422 Has_Per_Object_Constraint (Oent));
9423
9424 Append_To (Cdecls, New_Priv);
9425 end;
9426
9427 elsif Nkind (Priv) = N_Subprogram_Declaration then
9428
9429 -- Make the unprotected version of the subprogram available
9430 -- for expansion of intra object calls. There is need for
9431 -- a protected version only if the subprogram is an interrupt
9432 -- handler, otherwise this operation can only be called from
9433 -- within the body.
9434
9435 Sub :=
9436 Make_Subprogram_Declaration (Loc,
9437 Specification =>
9438 Build_Protected_Sub_Specification
9439 (Priv, Prot_Typ, Unprotected_Mode));
9440
9441 Insert_After (Current_Node, Sub);
9442 Analyze (Sub);
9443
9444 Set_Protected_Body_Subprogram
9445 (Defining_Unit_Name (Specification (Priv)),
9446 Defining_Unit_Name (Specification (Sub)));
9447 Check_Inlining (Defining_Unit_Name (Specification (Priv)));
9448 Current_Node := Sub;
9449
9450 Sub :=
9451 Make_Subprogram_Declaration (Loc,
9452 Specification =>
9453 Build_Protected_Sub_Specification
9454 (Priv, Prot_Typ, Protected_Mode));
9455
9456 Insert_After (Current_Node, Sub);
9457 Analyze (Sub);
9458 Current_Node := Sub;
9459
9460 if Is_Interrupt_Handler
9461 (Defining_Unit_Name (Specification (Priv)))
9462 then
9463 if not Restricted_Profile then
9464 Register_Handler;
9465 end if;
9466 end if;
9467 end if;
9468
9469 Next (Priv);
9470 end loop;
9471 end if;
9472
9473 -- Except for the lock-free implementation, append the _Object field
9474 -- with the right type to the component list. We need to compute the
9475 -- number of entries, and in some cases the number of Attach_Handler
9476 -- pragmas.
9477
9478 if not Lock_Free_Active then
9479 declare
9480 Entry_Count_Expr : constant Node_Id :=
9481 Build_Entry_Count_Expression
9482 (Prot_Typ, Cdecls, Loc);
9483 Num_Attach_Handler : Nat := 0;
9484 Protection_Subtype : Node_Id;
9485 Ritem : Node_Id;
9486
9487 begin
9488 if Has_Attach_Handler (Prot_Typ) then
9489 Ritem := First_Rep_Item (Prot_Typ);
9490 while Present (Ritem) loop
9491 if Nkind (Ritem) = N_Pragma
9492 and then Pragma_Name (Ritem) = Name_Attach_Handler
9493 then
9494 Num_Attach_Handler := Num_Attach_Handler + 1;
9495 end if;
9496
9497 Next_Rep_Item (Ritem);
9498 end loop;
9499 end if;
9500
9501 -- Determine the proper protection type. There are two special
9502 -- cases: 1) when the protected type has dynamic interrupt
9503 -- handlers, and 2) when it has static handlers and we use a
9504 -- restricted profile.
9505
9506 if Has_Attach_Handler (Prot_Typ)
9507 and then not Restricted_Profile
9508 then
9509 Protection_Subtype :=
9510 Make_Subtype_Indication (Loc,
9511 Subtype_Mark =>
9512 New_Occurrence_Of
9513 (RTE (RE_Static_Interrupt_Protection), Loc),
9514 Constraint =>
9515 Make_Index_Or_Discriminant_Constraint (Loc,
9516 Constraints => New_List (
9517 Entry_Count_Expr,
9518 Make_Integer_Literal (Loc, Num_Attach_Handler))));
9519
9520 elsif Has_Interrupt_Handler (Prot_Typ)
9521 and then not Restriction_Active (No_Dynamic_Attachment)
9522 then
9523 Protection_Subtype :=
9524 Make_Subtype_Indication (Loc,
9525 Subtype_Mark =>
9526 New_Occurrence_Of
9527 (RTE (RE_Dynamic_Interrupt_Protection), Loc),
9528 Constraint =>
9529 Make_Index_Or_Discriminant_Constraint (Loc,
9530 Constraints => New_List (Entry_Count_Expr)));
9531
9532 else
9533 case Corresponding_Runtime_Package (Prot_Typ) is
9534 when System_Tasking_Protected_Objects_Entries =>
9535 Protection_Subtype :=
9536 Make_Subtype_Indication (Loc,
9537 Subtype_Mark =>
9538 New_Occurrence_Of
9539 (RTE (RE_Protection_Entries), Loc),
9540 Constraint =>
9541 Make_Index_Or_Discriminant_Constraint (Loc,
9542 Constraints => New_List (Entry_Count_Expr)));
9543
9544 when System_Tasking_Protected_Objects_Single_Entry =>
9545 Protection_Subtype :=
9546 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc);
9547
9548 when System_Tasking_Protected_Objects =>
9549 Protection_Subtype :=
9550 New_Occurrence_Of (RTE (RE_Protection), Loc);
9551
9552 when others =>
9553 raise Program_Error;
9554 end case;
9555 end if;
9556
9557 Object_Comp :=
9558 Make_Component_Declaration (Loc,
9559 Defining_Identifier =>
9560 Make_Defining_Identifier (Loc, Name_uObject),
9561 Component_Definition =>
9562 Make_Component_Definition (Loc,
9563 Aliased_Present => True,
9564 Subtype_Indication => Protection_Subtype));
9565 end;
9566
9567 -- Put the _Object component after the private component so that it
9568 -- be finalized early as required by 9.4 (20)
9569
9570 Append_To (Cdecls, Object_Comp);
9571 end if;
9572
9573 Insert_After (Current_Node, Rec_Decl);
9574 Current_Node := Rec_Decl;
9575
9576 -- Analyze the record declaration immediately after construction,
9577 -- because the initialization procedure is needed for single object
9578 -- declarations before the next entity is analyzed (the freeze call
9579 -- that generates this initialization procedure is found below).
9580
9581 Analyze (Rec_Decl, Suppress => All_Checks);
9582
9583 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
9584 -- the corresponding record is frozen. If any wrappers are generated,
9585 -- Current_Node is updated accordingly.
9586
9587 if Ada_Version >= Ada_2005 then
9588 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node);
9589 end if;
9590
9591 -- Collect pointers to entry bodies and their barriers, to be placed
9592 -- in the Entry_Bodies_Array for the type. For each entry/family we
9593 -- add an expression to the aggregate which is the initial value of
9594 -- this array. The array is declared after all protected subprograms.
9595
9596 if Has_Entries (Prot_Typ) then
9597 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List);
9598 else
9599 Entries_Aggr := Empty;
9600 end if;
9601
9602 -- Build two new procedure specifications for each protected subprogram;
9603 -- one to call from outside the object and one to call from inside.
9604 -- Build a barrier function and an entry body action procedure
9605 -- specification for each protected entry. Initialize the entry body
9606 -- array. If subprogram is flagged as eliminated, do not generate any
9607 -- internal operations.
9608
9609 E_Count := 0;
9610 Comp := First (Visible_Declarations (Pdef));
9611 while Present (Comp) loop
9612 if Nkind (Comp) = N_Subprogram_Declaration then
9613 Sub :=
9614 Make_Subprogram_Declaration (Loc,
9615 Specification =>
9616 Build_Protected_Sub_Specification
9617 (Comp, Prot_Typ, Unprotected_Mode));
9618
9619 Insert_After (Current_Node, Sub);
9620 Analyze (Sub);
9621
9622 Set_Protected_Body_Subprogram
9623 (Defining_Unit_Name (Specification (Comp)),
9624 Defining_Unit_Name (Specification (Sub)));
9625 Check_Inlining (Defining_Unit_Name (Specification (Comp)));
9626
9627 -- Make the protected version of the subprogram available for
9628 -- expansion of external calls.
9629
9630 Current_Node := Sub;
9631
9632 Sub :=
9633 Make_Subprogram_Declaration (Loc,
9634 Specification =>
9635 Build_Protected_Sub_Specification
9636 (Comp, Prot_Typ, Protected_Mode));
9637
9638 Insert_After (Current_Node, Sub);
9639 Analyze (Sub);
9640
9641 Current_Node := Sub;
9642
9643 -- Generate an overriding primitive operation specification for
9644 -- this subprogram if the protected type implements an interface
9645 -- and Build_Wrapper_Spec did not generate its wrapper.
9646
9647 if Ada_Version >= Ada_2005
9648 and then
9649 Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
9650 then
9651 declare
9652 Found : Boolean := False;
9653 Prim_Elmt : Elmt_Id;
9654 Prim_Op : Node_Id;
9655
9656 begin
9657 Prim_Elmt :=
9658 First_Elmt
9659 (Primitive_Operations
9660 (Corresponding_Record_Type (Prot_Typ)));
9661
9662 while Present (Prim_Elmt) loop
9663 Prim_Op := Node (Prim_Elmt);
9664
9665 if Is_Primitive_Wrapper (Prim_Op)
9666 and then Wrapped_Entity (Prim_Op) =
9667 Defining_Entity (Specification (Comp))
9668 then
9669 Found := True;
9670 exit;
9671 end if;
9672
9673 Next_Elmt (Prim_Elmt);
9674 end loop;
9675
9676 if not Found then
9677 Sub :=
9678 Make_Subprogram_Declaration (Loc,
9679 Specification =>
9680 Build_Protected_Sub_Specification
9681 (Comp, Prot_Typ, Dispatching_Mode));
9682
9683 Insert_After (Current_Node, Sub);
9684 Analyze (Sub);
9685
9686 Current_Node := Sub;
9687 end if;
9688 end;
9689 end if;
9690
9691 -- If a pragma Interrupt_Handler applies, build and add a call to
9692 -- Register_Interrupt_Handler to the freezing actions of the
9693 -- protected version (Current_Node) of the subprogram:
9694
9695 -- system.interrupts.register_interrupt_handler
9696 -- (prot_procP'address);
9697
9698 if not Restricted_Profile
9699 and then Is_Interrupt_Handler
9700 (Defining_Unit_Name (Specification (Comp)))
9701 then
9702 Register_Handler;
9703 end if;
9704
9705 elsif Nkind (Comp) = N_Entry_Declaration then
9706 Expand_Entry_Declaration (Comp);
9707 end if;
9708
9709 Next (Comp);
9710 end loop;
9711
9712 -- If there are some private entry declarations, expand it as if they
9713 -- were visible entries.
9714
9715 if Present (Private_Declarations (Pdef)) then
9716 Comp := First (Private_Declarations (Pdef));
9717 while Present (Comp) loop
9718 if Nkind (Comp) = N_Entry_Declaration then
9719 Expand_Entry_Declaration (Comp);
9720 end if;
9721
9722 Next (Comp);
9723 end loop;
9724 end if;
9725
9726 -- Emit declaration for Entry_Bodies_Array, now that the addresses of
9727 -- all protected subprograms have been collected.
9728
9729 if Has_Entries (Prot_Typ) then
9730 Body_Id :=
9731 Make_Defining_Identifier (Sloc (Prot_Typ),
9732 Chars => New_External_Name (Chars (Prot_Typ), 'A'));
9733
9734 case Corresponding_Runtime_Package (Prot_Typ) is
9735 when System_Tasking_Protected_Objects_Entries =>
9736 Body_Arr :=
9737 Make_Object_Declaration (Loc,
9738 Defining_Identifier => Body_Id,
9739 Aliased_Present => True,
9740 Object_Definition =>
9741 Make_Subtype_Indication (Loc,
9742 Subtype_Mark =>
9743 New_Occurrence_Of
9744 (RTE (RE_Protected_Entry_Body_Array), Loc),
9745 Constraint =>
9746 Make_Index_Or_Discriminant_Constraint (Loc,
9747 Constraints => New_List (
9748 Make_Range (Loc,
9749 Make_Integer_Literal (Loc, 1),
9750 Make_Integer_Literal (Loc, E_Count))))),
9751 Expression => Entries_Aggr);
9752
9753 when System_Tasking_Protected_Objects_Single_Entry =>
9754 Body_Arr :=
9755 Make_Object_Declaration (Loc,
9756 Defining_Identifier => Body_Id,
9757 Aliased_Present => True,
9758 Object_Definition =>
9759 New_Occurrence_Of (RTE (RE_Entry_Body), Loc),
9760 Expression =>
9761 Remove_Head (Expressions (Entries_Aggr)));
9762
9763 when others =>
9764 raise Program_Error;
9765 end case;
9766
9767 -- A pointer to this array will be placed in the corresponding record
9768 -- by its initialization procedure so this needs to be analyzed here.
9769
9770 Insert_After (Current_Node, Body_Arr);
9771 Current_Node := Body_Arr;
9772 Analyze (Body_Arr);
9773
9774 Set_Entry_Bodies_Array (Prot_Typ, Body_Id);
9775
9776 -- Finally, build the function that maps an entry index into the
9777 -- corresponding body. A pointer to this function is placed in each
9778 -- object of the type. Except for a ravenscar-like profile (no abort,
9779 -- no entry queue, 1 entry)
9780
9781 if Corresponding_Runtime_Package (Prot_Typ) =
9782 System_Tasking_Protected_Objects_Entries
9783 then
9784 Sub :=
9785 Make_Subprogram_Declaration (Loc,
9786 Specification => Build_Find_Body_Index_Spec (Prot_Typ));
9787 Insert_After (Current_Node, Sub);
9788 Analyze (Sub);
9789 end if;
9790 end if;
9791 end Expand_N_Protected_Type_Declaration;
9792
9793 --------------------------------
9794 -- Expand_N_Requeue_Statement --
9795 --------------------------------
9796
9797 -- A nondispatching requeue statement is expanded into one of four GNARLI
9798 -- operations, depending on the source and destination (task or protected
9799 -- object). A dispatching requeue statement is expanded into a call to the
9800 -- predefined primitive _Disp_Requeue. In addition, code is generated to
9801 -- jump around the remainder of processing for the original entry and, if
9802 -- the destination is (different) protected object, to attempt to service
9803 -- it. The following illustrates the various cases:
9804
9805 -- procedure entE
9806 -- (O : System.Address;
9807 -- P : System.Address;
9808 -- E : Protected_Entry_Index)
9809 -- is
9810 -- <discriminant renamings>
9811 -- <private object renamings>
9812 -- type poVP is access poV;
9813 -- _object : ptVP := ptVP!(O);
9814
9815 -- begin
9816 -- begin
9817 -- <start of statement sequence for entry>
9818
9819 -- -- Requeue from one protected entry body to another protected
9820 -- -- entry.
9821
9822 -- Requeue_Protected_Entry (
9823 -- _object._object'Access,
9824 -- new._object'Access,
9825 -- E,
9826 -- Abort_Present);
9827 -- return;
9828
9829 -- <some more of the statement sequence for entry>
9830
9831 -- -- Requeue from an entry body to a task entry
9832
9833 -- Requeue_Protected_To_Task_Entry (
9834 -- New._task_id,
9835 -- E,
9836 -- Abort_Present);
9837 -- return;
9838
9839 -- <rest of statement sequence for entry>
9840 -- Complete_Entry_Body (_object._object);
9841
9842 -- exception
9843 -- when all others =>
9844 -- Exceptional_Complete_Entry_Body (
9845 -- _object._object, Get_GNAT_Exception);
9846 -- end;
9847 -- end entE;
9848
9849 -- Requeue of a task entry call to a task entry
9850
9851 -- Accept_Call (E, Ann);
9852 -- <start of statement sequence for accept statement>
9853 -- Requeue_Task_Entry (New._task_id, E, Abort_Present);
9854 -- goto Lnn;
9855 -- <rest of statement sequence for accept statement>
9856 -- <<Lnn>>
9857 -- Complete_Rendezvous;
9858
9859 -- exception
9860 -- when all others =>
9861 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9862
9863 -- Requeue of a task entry call to a protected entry
9864
9865 -- Accept_Call (E, Ann);
9866 -- <start of statement sequence for accept statement>
9867 -- Requeue_Task_To_Protected_Entry (
9868 -- new._object'Access,
9869 -- E,
9870 -- Abort_Present);
9871 -- newS (new, Pnn);
9872 -- goto Lnn;
9873 -- <rest of statement sequence for accept statement>
9874 -- <<Lnn>>
9875 -- Complete_Rendezvous;
9876
9877 -- exception
9878 -- when all others =>
9879 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9880
9881 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9882 -- marked by pragma Implemented (XXX, By_Entry).
9883
9884 -- The requeue is inside a protected entry:
9885
9886 -- procedure entE
9887 -- (O : System.Address;
9888 -- P : System.Address;
9889 -- E : Protected_Entry_Index)
9890 -- is
9891 -- <discriminant renamings>
9892 -- <private object renamings>
9893 -- type poVP is access poV;
9894 -- _object : ptVP := ptVP!(O);
9895
9896 -- begin
9897 -- begin
9898 -- <start of statement sequence for entry>
9899
9900 -- _Disp_Requeue
9901 -- (<interface class-wide object>,
9902 -- True,
9903 -- _object'Address,
9904 -- Ada.Tags.Get_Offset_Index
9905 -- (Tag (_object),
9906 -- <interface dispatch table index of target entry>),
9907 -- Abort_Present);
9908 -- return;
9909
9910 -- <rest of statement sequence for entry>
9911 -- Complete_Entry_Body (_object._object);
9912
9913 -- exception
9914 -- when all others =>
9915 -- Exceptional_Complete_Entry_Body (
9916 -- _object._object, Get_GNAT_Exception);
9917 -- end;
9918 -- end entE;
9919
9920 -- The requeue is inside a task entry:
9921
9922 -- Accept_Call (E, Ann);
9923 -- <start of statement sequence for accept statement>
9924 -- _Disp_Requeue
9925 -- (<interface class-wide object>,
9926 -- False,
9927 -- null,
9928 -- Ada.Tags.Get_Offset_Index
9929 -- (Tag (_object),
9930 -- <interface dispatch table index of target entrt>),
9931 -- Abort_Present);
9932 -- newS (new, Pnn);
9933 -- goto Lnn;
9934 -- <rest of statement sequence for accept statement>
9935 -- <<Lnn>>
9936 -- Complete_Rendezvous;
9937
9938 -- exception
9939 -- when all others =>
9940 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
9941
9942 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9943 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue
9944 -- statement is replaced by a dispatching call with actual parameters taken
9945 -- from the inner-most accept statement or entry body.
9946
9947 -- Target.Primitive (Param1, ..., ParamN);
9948
9949 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive
9950 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked
9951 -- at all.
9952
9953 -- declare
9954 -- S : constant Offset_Index :=
9955 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename));
9956 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S);
9957
9958 -- begin
9959 -- if C = POK_Protected_Entry
9960 -- or else C = POK_Task_Entry
9961 -- then
9962 -- <statements for dispatching requeue>
9963
9964 -- elsif C = POK_Protected_Procedure then
9965 -- <dispatching call equivalent>
9966
9967 -- else
9968 -- raise Program_Error;
9969 -- end if;
9970 -- end;
9971
9972 procedure Expand_N_Requeue_Statement (N : Node_Id) is
9973 Loc : constant Source_Ptr := Sloc (N);
9974 Conc_Typ : Entity_Id;
9975 Concval : Node_Id;
9976 Ename : Node_Id;
9977 Index : Node_Id;
9978 Old_Typ : Entity_Id;
9979
9980 function Build_Dispatching_Call_Equivalent return Node_Id;
9981 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9982 -- the form Concval.Ename. It is statically known that Ename is allowed
9983 -- to be implemented by a protected procedure. Create a dispatching call
9984 -- equivalent of Concval.Ename taking the actual parameters from the
9985 -- inner-most accept statement or entry body.
9986
9987 function Build_Dispatching_Requeue return Node_Id;
9988 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9989 -- the form Concval.Ename. It is statically known that Ename is allowed
9990 -- to be implemented by a protected or a task entry. Create a call to
9991 -- primitive _Disp_Requeue which handles the low-level actions.
9992
9993 function Build_Dispatching_Requeue_To_Any return Node_Id;
9994 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of
9995 -- the form Concval.Ename. Ename is either marked by pragma Implemented
9996 -- (XXX, By_Any | Optional) or not marked at all. Create a block which
9997 -- determines at runtime whether Ename denotes an entry or a procedure
9998 -- and perform the appropriate kind of dispatching select.
9999
10000 function Build_Normal_Requeue return Node_Id;
10001 -- N denotes a nondispatching requeue statement to either a task or a
10002 -- protected entry. Build the appropriate runtime call to perform the
10003 -- action.
10004
10005 function Build_Skip_Statement (Search : Node_Id) return Node_Id;
10006 -- For a protected entry, create a return statement to skip the rest of
10007 -- the entry body. Otherwise, create a goto statement to skip the rest
10008 -- of a task accept statement. The lookup for the enclosing entry body
10009 -- or accept statement starts from Search.
10010
10011 ---------------------------------------
10012 -- Build_Dispatching_Call_Equivalent --
10013 ---------------------------------------
10014
10015 function Build_Dispatching_Call_Equivalent return Node_Id is
10016 Call_Ent : constant Entity_Id := Entity (Ename);
10017 Obj : constant Node_Id := Original_Node (Concval);
10018 Acc_Ent : Node_Id;
10019 Actuals : List_Id;
10020 Formal : Node_Id;
10021 Formals : List_Id;
10022
10023 begin
10024 -- Climb the parent chain looking for the inner-most entry body or
10025 -- accept statement.
10026
10027 Acc_Ent := N;
10028 while Present (Acc_Ent)
10029 and then not Nkind_In (Acc_Ent, N_Accept_Statement,
10030 N_Entry_Body)
10031 loop
10032 Acc_Ent := Parent (Acc_Ent);
10033 end loop;
10034
10035 -- A requeue statement should be housed inside an entry body or an
10036 -- accept statement at some level. If this is not the case, then the
10037 -- tree is malformed.
10038
10039 pragma Assert (Present (Acc_Ent));
10040
10041 -- Recover the list of formal parameters
10042
10043 if Nkind (Acc_Ent) = N_Entry_Body then
10044 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent);
10045 end if;
10046
10047 Formals := Parameter_Specifications (Acc_Ent);
10048
10049 -- Create the actual parameters for the dispatching call. These are
10050 -- simply copies of the entry body or accept statement formals in the
10051 -- same order as they appear.
10052
10053 Actuals := No_List;
10054
10055 if Present (Formals) then
10056 Actuals := New_List;
10057 Formal := First (Formals);
10058 while Present (Formal) loop
10059 Append_To (Actuals,
10060 Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
10061 Next (Formal);
10062 end loop;
10063 end if;
10064
10065 -- Generate:
10066 -- Obj.Call_Ent (Actuals);
10067
10068 return
10069 Make_Procedure_Call_Statement (Loc,
10070 Name =>
10071 Make_Selected_Component (Loc,
10072 Prefix => Make_Identifier (Loc, Chars (Obj)),
10073 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))),
10074
10075 Parameter_Associations => Actuals);
10076 end Build_Dispatching_Call_Equivalent;
10077
10078 -------------------------------
10079 -- Build_Dispatching_Requeue --
10080 -------------------------------
10081
10082 function Build_Dispatching_Requeue return Node_Id is
10083 Params : constant List_Id := New_List;
10084
10085 begin
10086 -- Process the "with abort" parameter
10087
10088 Prepend_To (Params,
10089 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc));
10090
10091 -- Process the entry wrapper's position in the primary dispatch
10092 -- table parameter. Generate:
10093
10094 -- Ada.Tags.Get_Entry_Index
10095 -- (T => To_Tag_Ptr (Obj'Address).all,
10096 -- Position =>
10097 -- Ada.Tags.Get_Offset_Index
10098 -- (Ada.Tags.Tag (Concval),
10099 -- <interface dispatch table position of Ename>));
10100
10101 -- Note that Obj'Address is recursively expanded into a call to
10102 -- Base_Address (Obj).
10103
10104 if Tagged_Type_Expansion then
10105 Prepend_To (Params,
10106 Make_Function_Call (Loc,
10107 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
10108 Parameter_Associations => New_List (
10109
10110 Make_Explicit_Dereference (Loc,
10111 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
10112 Make_Attribute_Reference (Loc,
10113 Prefix => New_Copy_Tree (Concval),
10114 Attribute_Name => Name_Address))),
10115
10116 Make_Function_Call (Loc,
10117 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
10118 Parameter_Associations => New_List (
10119 Unchecked_Convert_To (RTE (RE_Tag), Concval),
10120 Make_Integer_Literal (Loc,
10121 DT_Position (Entity (Ename))))))));
10122
10123 -- VM targets
10124
10125 else
10126 Prepend_To (Params,
10127 Make_Function_Call (Loc,
10128 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc),
10129 Parameter_Associations => New_List (
10130
10131 Make_Attribute_Reference (Loc,
10132 Prefix => Concval,
10133 Attribute_Name => Name_Tag),
10134
10135 Make_Function_Call (Loc,
10136 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc),
10137
10138 Parameter_Associations => New_List (
10139
10140 -- Obj_Tag
10141
10142 Make_Attribute_Reference (Loc,
10143 Prefix => Concval,
10144 Attribute_Name => Name_Tag),
10145
10146 -- Tag_Typ
10147
10148 Make_Attribute_Reference (Loc,
10149 Prefix => New_Occurrence_Of (Etype (Concval), Loc),
10150 Attribute_Name => Name_Tag),
10151
10152 -- Position
10153
10154 Make_Integer_Literal (Loc,
10155 DT_Position (Entity (Ename))))))));
10156 end if;
10157
10158 -- Specific actuals for protected to XXX requeue
10159
10160 if Is_Protected_Type (Old_Typ) then
10161 Prepend_To (Params,
10162 Make_Attribute_Reference (Loc, -- _object'Address
10163 Prefix =>
10164 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
10165 Attribute_Name => Name_Address));
10166
10167 Prepend_To (Params, -- True
10168 New_Occurrence_Of (Standard_True, Loc));
10169
10170 -- Specific actuals for task to XXX requeue
10171
10172 else
10173 pragma Assert (Is_Task_Type (Old_Typ));
10174
10175 Prepend_To (Params, -- null
10176 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
10177
10178 Prepend_To (Params, -- False
10179 New_Occurrence_Of (Standard_False, Loc));
10180 end if;
10181
10182 -- Add the object parameter
10183
10184 Prepend_To (Params, New_Copy_Tree (Concval));
10185
10186 -- Generate:
10187 -- _Disp_Requeue (<Params>);
10188
10189 -- Find entity for Disp_Requeue operation, which belongs to
10190 -- the type and may not be directly visible.
10191
10192 declare
10193 Elmt : Elmt_Id;
10194 Op : Entity_Id;
10195
10196 begin
10197 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ)));
10198 while Present (Elmt) loop
10199 Op := Node (Elmt);
10200 exit when Chars (Op) = Name_uDisp_Requeue;
10201 Next_Elmt (Elmt);
10202 end loop;
10203
10204 return
10205 Make_Procedure_Call_Statement (Loc,
10206 Name => New_Occurrence_Of (Op, Loc),
10207 Parameter_Associations => Params);
10208 end;
10209 end Build_Dispatching_Requeue;
10210
10211 --------------------------------------
10212 -- Build_Dispatching_Requeue_To_Any --
10213 --------------------------------------
10214
10215 function Build_Dispatching_Requeue_To_Any return Node_Id is
10216 Call_Ent : constant Entity_Id := Entity (Ename);
10217 Obj : constant Node_Id := Original_Node (Concval);
10218 Skip : constant Node_Id := Build_Skip_Statement (N);
10219 C : Entity_Id;
10220 Decls : List_Id;
10221 S : Entity_Id;
10222 Stmts : List_Id;
10223
10224 begin
10225 Decls := New_List;
10226 Stmts := New_List;
10227
10228 -- Dispatch table slot processing, generate:
10229 -- S : Integer;
10230
10231 S := Build_S (Loc, Decls);
10232
10233 -- Call kind processing, generate:
10234 -- C : Ada.Tags.Prim_Op_Kind;
10235
10236 C := Build_C (Loc, Decls);
10237
10238 -- Generate:
10239 -- S := Ada.Tags.Get_Offset_Index
10240 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent));
10241
10242 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent));
10243
10244 -- Generate:
10245 -- _Disp_Get_Prim_Op_Kind (Obj, S, C);
10246
10247 Append_To (Stmts,
10248 Make_Procedure_Call_Statement (Loc,
10249 Name =>
10250 New_Occurrence_Of (
10251 Find_Prim_Op (Etype (Etype (Obj)),
10252 Name_uDisp_Get_Prim_Op_Kind),
10253 Loc),
10254 Parameter_Associations => New_List (
10255 New_Copy_Tree (Obj),
10256 New_Occurrence_Of (S, Loc),
10257 New_Occurrence_Of (C, Loc))));
10258
10259 Append_To (Stmts,
10260
10261 -- if C = POK_Protected_Entry
10262 -- or else C = POK_Task_Entry
10263 -- then
10264
10265 Make_Implicit_If_Statement (N,
10266 Condition =>
10267 Make_Op_Or (Loc,
10268 Left_Opnd =>
10269 Make_Op_Eq (Loc,
10270 Left_Opnd =>
10271 New_Occurrence_Of (C, Loc),
10272 Right_Opnd =>
10273 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)),
10274
10275 Right_Opnd =>
10276 Make_Op_Eq (Loc,
10277 Left_Opnd =>
10278 New_Occurrence_Of (C, Loc),
10279 Right_Opnd =>
10280 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
10281
10282 -- Dispatching requeue equivalent
10283
10284 Then_Statements => New_List (
10285 Build_Dispatching_Requeue,
10286 Skip),
10287
10288 -- elsif C = POK_Protected_Procedure then
10289
10290 Elsif_Parts => New_List (
10291 Make_Elsif_Part (Loc,
10292 Condition =>
10293 Make_Op_Eq (Loc,
10294 Left_Opnd =>
10295 New_Occurrence_Of (C, Loc),
10296 Right_Opnd =>
10297 New_Occurrence_Of (
10298 RTE (RE_POK_Protected_Procedure), Loc)),
10299
10300 -- Dispatching call equivalent
10301
10302 Then_Statements => New_List (
10303 Build_Dispatching_Call_Equivalent))),
10304
10305 -- else
10306 -- raise Program_Error;
10307 -- end if;
10308
10309 Else_Statements => New_List (
10310 Make_Raise_Program_Error (Loc,
10311 Reason => PE_Explicit_Raise))));
10312
10313 -- Wrap everything into a block
10314
10315 return
10316 Make_Block_Statement (Loc,
10317 Declarations => Decls,
10318 Handled_Statement_Sequence =>
10319 Make_Handled_Sequence_Of_Statements (Loc,
10320 Statements => Stmts));
10321 end Build_Dispatching_Requeue_To_Any;
10322
10323 --------------------------
10324 -- Build_Normal_Requeue --
10325 --------------------------
10326
10327 function Build_Normal_Requeue return Node_Id is
10328 Params : constant List_Id := New_List;
10329 Param : Node_Id;
10330 RT_Call : Node_Id;
10331
10332 begin
10333 -- Process the "with abort" parameter
10334
10335 Prepend_To (Params,
10336 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc));
10337
10338 -- Add the index expression to the parameters. It is common among all
10339 -- four cases.
10340
10341 Prepend_To (Params,
10342 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ));
10343
10344 if Is_Protected_Type (Old_Typ) then
10345 declare
10346 Self_Param : Node_Id;
10347
10348 begin
10349 Self_Param :=
10350 Make_Attribute_Reference (Loc,
10351 Prefix =>
10352 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)),
10353 Attribute_Name =>
10354 Name_Unchecked_Access);
10355
10356 -- Protected to protected requeue
10357
10358 if Is_Protected_Type (Conc_Typ) then
10359 RT_Call :=
10360 New_Occurrence_Of (
10361 RTE (RE_Requeue_Protected_Entry), Loc);
10362
10363 Param :=
10364 Make_Attribute_Reference (Loc,
10365 Prefix =>
10366 Concurrent_Ref (Concval),
10367 Attribute_Name =>
10368 Name_Unchecked_Access);
10369
10370 -- Protected to task requeue
10371
10372 else pragma Assert (Is_Task_Type (Conc_Typ));
10373 RT_Call :=
10374 New_Occurrence_Of (
10375 RTE (RE_Requeue_Protected_To_Task_Entry), Loc);
10376
10377 Param := Concurrent_Ref (Concval);
10378 end if;
10379
10380 Prepend_To (Params, Param);
10381 Prepend_To (Params, Self_Param);
10382 end;
10383
10384 else pragma Assert (Is_Task_Type (Old_Typ));
10385
10386 -- Task to protected requeue
10387
10388 if Is_Protected_Type (Conc_Typ) then
10389 RT_Call :=
10390 New_Occurrence_Of (
10391 RTE (RE_Requeue_Task_To_Protected_Entry), Loc);
10392
10393 Param :=
10394 Make_Attribute_Reference (Loc,
10395 Prefix =>
10396 Concurrent_Ref (Concval),
10397 Attribute_Name =>
10398 Name_Unchecked_Access);
10399
10400 -- Task to task requeue
10401
10402 else pragma Assert (Is_Task_Type (Conc_Typ));
10403 RT_Call :=
10404 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc);
10405
10406 Param := Concurrent_Ref (Concval);
10407 end if;
10408
10409 Prepend_To (Params, Param);
10410 end if;
10411
10412 return
10413 Make_Procedure_Call_Statement (Loc,
10414 Name => RT_Call,
10415 Parameter_Associations => Params);
10416 end Build_Normal_Requeue;
10417
10418 --------------------------
10419 -- Build_Skip_Statement --
10420 --------------------------
10421
10422 function Build_Skip_Statement (Search : Node_Id) return Node_Id is
10423 Skip_Stmt : Node_Id;
10424
10425 begin
10426 -- Build a return statement to skip the rest of the entire body
10427
10428 if Is_Protected_Type (Old_Typ) then
10429 Skip_Stmt := Make_Simple_Return_Statement (Loc);
10430
10431 -- If the requeue is within a task, find the end label of the
10432 -- enclosing accept statement and create a goto statement to it.
10433
10434 else
10435 declare
10436 Acc : Node_Id;
10437 Label : Node_Id;
10438
10439 begin
10440 -- Climb the parent chain looking for the enclosing accept
10441 -- statement.
10442
10443 Acc := Parent (Search);
10444 while Present (Acc)
10445 and then Nkind (Acc) /= N_Accept_Statement
10446 loop
10447 Acc := Parent (Acc);
10448 end loop;
10449
10450 -- The last statement is the second label used for completing
10451 -- the rendezvous the usual way. The label we are looking for
10452 -- is right before it.
10453
10454 Label :=
10455 Prev (Last (Statements (Handled_Statement_Sequence (Acc))));
10456
10457 pragma Assert (Nkind (Label) = N_Label);
10458
10459 -- Generate a goto statement to skip the rest of the accept
10460
10461 Skip_Stmt :=
10462 Make_Goto_Statement (Loc,
10463 Name =>
10464 New_Occurrence_Of (Entity (Identifier (Label)), Loc));
10465 end;
10466 end if;
10467
10468 Set_Analyzed (Skip_Stmt);
10469
10470 return Skip_Stmt;
10471 end Build_Skip_Statement;
10472
10473 -- Start of processing for Expand_N_Requeue_Statement
10474
10475 begin
10476 -- Extract the components of the entry call
10477
10478 Extract_Entry (N, Concval, Ename, Index);
10479 Conc_Typ := Etype (Concval);
10480
10481 -- If the prefix is an access to class-wide type, dereference to get
10482 -- object and entry type.
10483
10484 if Is_Access_Type (Conc_Typ) then
10485 Conc_Typ := Designated_Type (Conc_Typ);
10486 Rewrite (Concval,
10487 Make_Explicit_Dereference (Loc, Relocate_Node (Concval)));
10488 Analyze_And_Resolve (Concval, Conc_Typ);
10489 end if;
10490
10491 -- Examine the scope stack in order to find nearest enclosing protected
10492 -- or task type. This will constitute our invocation source.
10493
10494 Old_Typ := Current_Scope;
10495 while Present (Old_Typ)
10496 and then not Is_Protected_Type (Old_Typ)
10497 and then not Is_Task_Type (Old_Typ)
10498 loop
10499 Old_Typ := Scope (Old_Typ);
10500 end loop;
10501
10502 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form
10503 -- Concval.Ename where the type of Concval is class-wide concurrent
10504 -- interface.
10505
10506 if Ada_Version >= Ada_2012
10507 and then Present (Concval)
10508 and then Is_Class_Wide_Type (Conc_Typ)
10509 and then Is_Concurrent_Interface (Conc_Typ)
10510 then
10511 declare
10512 Has_Impl : Boolean := False;
10513 Impl_Kind : Name_Id := No_Name;
10514
10515 begin
10516 -- Check whether the Ename is flagged by pragma Implemented
10517
10518 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then
10519 Has_Impl := True;
10520 Impl_Kind := Implementation_Kind (Entity (Ename));
10521 end if;
10522
10523 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10524 -- an entry. Create a call to predefined primitive _Disp_Requeue.
10525
10526 if Has_Impl and then Impl_Kind = Name_By_Entry then
10527 Rewrite (N, Build_Dispatching_Requeue);
10528 Analyze (N);
10529 Insert_After (N, Build_Skip_Statement (N));
10530
10531 -- The procedure_or_entry_NAME is guaranteed to be overridden by
10532 -- a protected procedure. In this case the requeue is transformed
10533 -- into a dispatching call.
10534
10535 elsif Has_Impl
10536 and then Impl_Kind = Name_By_Protected_Procedure
10537 then
10538 Rewrite (N, Build_Dispatching_Call_Equivalent);
10539 Analyze (N);
10540
10541 -- The procedure_or_entry_NAME's implementation kind is either
10542 -- By_Any, Optional, or pragma Implemented was not applied at all.
10543 -- In this case a runtime test determines whether Ename denotes an
10544 -- entry or a protected procedure and performs the appropriate
10545 -- call.
10546
10547 else
10548 Rewrite (N, Build_Dispatching_Requeue_To_Any);
10549 Analyze (N);
10550 end if;
10551 end;
10552
10553 -- Processing for regular (nondispatching) requeues
10554
10555 else
10556 Rewrite (N, Build_Normal_Requeue);
10557 Analyze (N);
10558 Insert_After (N, Build_Skip_Statement (N));
10559 end if;
10560 end Expand_N_Requeue_Statement;
10561
10562 -------------------------------
10563 -- Expand_N_Selective_Accept --
10564 -------------------------------
10565
10566 procedure Expand_N_Selective_Accept (N : Node_Id) is
10567 Loc : constant Source_Ptr := Sloc (N);
10568 Alts : constant List_Id := Select_Alternatives (N);
10569
10570 -- Note: in the below declarations a lot of new lists are allocated
10571 -- unconditionally which may well not end up being used. That's not
10572 -- a good idea since it wastes space gratuitously ???
10573
10574 Accept_Case : List_Id;
10575 Accept_List : constant List_Id := New_List;
10576
10577 Alt : Node_Id;
10578 Alt_List : constant List_Id := New_List;
10579 Alt_Stats : List_Id;
10580 Ann : Entity_Id := Empty;
10581
10582 Check_Guard : Boolean := True;
10583
10584 Decls : constant List_Id := New_List;
10585 Stats : constant List_Id := New_List;
10586 Body_List : constant List_Id := New_List;
10587 Trailing_List : constant List_Id := New_List;
10588
10589 Choices : List_Id;
10590 Else_Present : Boolean := False;
10591 Terminate_Alt : Node_Id := Empty;
10592 Select_Mode : Node_Id;
10593
10594 Delay_Case : List_Id;
10595 Delay_Count : Integer := 0;
10596 Delay_Val : Entity_Id;
10597 Delay_Index : Entity_Id;
10598 Delay_Min : Entity_Id;
10599 Delay_Num : Pos := 1;
10600 Delay_Alt_List : List_Id := New_List;
10601 Delay_List : constant List_Id := New_List;
10602 D : Entity_Id;
10603 M : Entity_Id;
10604
10605 First_Delay : Boolean := True;
10606 Guard_Open : Entity_Id;
10607
10608 End_Lab : Node_Id;
10609 Index : Pos := 1;
10610 Lab : Node_Id;
10611 Num_Alts : Nat;
10612 Num_Accept : Nat := 0;
10613 Proc : Node_Id;
10614 Time_Type : Entity_Id;
10615 Select_Call : Node_Id;
10616
10617 Qnam : constant Entity_Id :=
10618 Make_Defining_Identifier (Loc, New_External_Name ('S', 0));
10619
10620 Xnam : constant Entity_Id :=
10621 Make_Defining_Identifier (Loc, New_External_Name ('J', 1));
10622
10623 -----------------------
10624 -- Local subprograms --
10625 -----------------------
10626
10627 function Accept_Or_Raise return List_Id;
10628 -- For the rare case where delay alternatives all have guards, and
10629 -- all of them are closed, it is still possible that there were open
10630 -- accept alternatives with no callers. We must reexamine the
10631 -- Accept_List, and execute a selective wait with no else if some
10632 -- accept is open. If none, we raise program_error.
10633
10634 procedure Add_Accept (Alt : Node_Id);
10635 -- Process a single accept statement in a select alternative. Build
10636 -- procedure for body of accept, and add entry to dispatch table with
10637 -- expression for guard, in preparation for call to run time select.
10638
10639 function Make_And_Declare_Label (Num : Int) return Node_Id;
10640 -- Manufacture a label using Num as a serial number and declare it.
10641 -- The declaration is appended to Decls. The label marks the trailing
10642 -- statements of an accept or delay alternative.
10643
10644 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id;
10645 -- Build call to Selective_Wait runtime routine
10646
10647 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int);
10648 -- Add code to compare value of delay with previous values, and
10649 -- generate case entry for trailing statements.
10650
10651 procedure Process_Accept_Alternative
10652 (Alt : Node_Id;
10653 Index : Int;
10654 Proc : Node_Id);
10655 -- Add code to call corresponding procedure, and branch to
10656 -- trailing statements, if any.
10657
10658 ---------------------
10659 -- Accept_Or_Raise --
10660 ---------------------
10661
10662 function Accept_Or_Raise return List_Id is
10663 Cond : Node_Id;
10664 Stats : List_Id;
10665 J : constant Entity_Id := Make_Temporary (Loc, 'J');
10666
10667 begin
10668 -- We generate the following:
10669
10670 -- for J in q'range loop
10671 -- if q(J).S /=null_task_entry then
10672 -- selective_wait (simple_mode,...);
10673 -- done := True;
10674 -- exit;
10675 -- end if;
10676 -- end loop;
10677 --
10678 -- if no rendez_vous then
10679 -- raise program_error;
10680 -- end if;
10681
10682 -- Note that the code needs to know that the selector name
10683 -- in an Accept_Alternative is named S.
10684
10685 Cond := Make_Op_Ne (Loc,
10686 Left_Opnd =>
10687 Make_Selected_Component (Loc,
10688 Prefix =>
10689 Make_Indexed_Component (Loc,
10690 Prefix => New_Occurrence_Of (Qnam, Loc),
10691 Expressions => New_List (New_Occurrence_Of (J, Loc))),
10692 Selector_Name => Make_Identifier (Loc, Name_S)),
10693 Right_Opnd =>
10694 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc));
10695
10696 Stats := New_List (
10697 Make_Implicit_Loop_Statement (N,
10698 Iteration_Scheme =>
10699 Make_Iteration_Scheme (Loc,
10700 Loop_Parameter_Specification =>
10701 Make_Loop_Parameter_Specification (Loc,
10702 Defining_Identifier => J,
10703 Discrete_Subtype_Definition =>
10704 Make_Attribute_Reference (Loc,
10705 Prefix => New_Occurrence_Of (Qnam, Loc),
10706 Attribute_Name => Name_Range,
10707 Expressions => New_List (
10708 Make_Integer_Literal (Loc, 1))))),
10709
10710 Statements => New_List (
10711 Make_Implicit_If_Statement (N,
10712 Condition => Cond,
10713 Then_Statements => New_List (
10714 Make_Select_Call (
10715 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)),
10716 Make_Exit_Statement (Loc))))));
10717
10718 Append_To (Stats,
10719 Make_Raise_Program_Error (Loc,
10720 Condition => Make_Op_Eq (Loc,
10721 Left_Opnd => New_Occurrence_Of (Xnam, Loc),
10722 Right_Opnd =>
10723 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)),
10724 Reason => PE_All_Guards_Closed));
10725
10726 return Stats;
10727 end Accept_Or_Raise;
10728
10729 ----------------
10730 -- Add_Accept --
10731 ----------------
10732
10733 procedure Add_Accept (Alt : Node_Id) is
10734 Acc_Stm : constant Node_Id := Accept_Statement (Alt);
10735 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm);
10736 Eloc : constant Source_Ptr := Sloc (Ename);
10737 Eent : constant Entity_Id := Entity (Ename);
10738 Index : constant Node_Id := Entry_Index (Acc_Stm);
10739 Null_Body : Node_Id;
10740 Proc_Body : Node_Id;
10741 PB_Ent : Entity_Id;
10742 Expr : Node_Id;
10743 Call : Node_Id;
10744
10745 begin
10746 if No (Ann) then
10747 Ann := Node (Last_Elmt (Accept_Address (Eent)));
10748 end if;
10749
10750 if Present (Condition (Alt)) then
10751 Expr :=
10752 Make_If_Expression (Eloc, New_List (
10753 Condition (Alt),
10754 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)),
10755 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc)));
10756 else
10757 Expr :=
10758 Entry_Index_Expression
10759 (Eloc, Eent, Index, Scope (Eent));
10760 end if;
10761
10762 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
10763 Null_Body := New_Occurrence_Of (Standard_False, Eloc);
10764
10765 -- Always add call to Abort_Undefer when generating code, since
10766 -- this is what the runtime expects (abort deferred in
10767 -- Selective_Wait). In CodePeer mode this only confuses the
10768 -- analysis with unknown calls, so don't do it.
10769
10770 if not CodePeer_Mode then
10771 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
10772 Insert_Before
10773 (First (Statements (Handled_Statement_Sequence
10774 (Accept_Statement (Alt)))),
10775 Call);
10776 Analyze (Call);
10777 end if;
10778
10779 PB_Ent :=
10780 Make_Defining_Identifier (Eloc,
10781 New_External_Name (Chars (Ename), 'A', Num_Accept));
10782
10783 if Comes_From_Source (Alt) then
10784 Set_Debug_Info_Needed (PB_Ent);
10785 end if;
10786
10787 Proc_Body :=
10788 Make_Subprogram_Body (Eloc,
10789 Specification =>
10790 Make_Procedure_Specification (Eloc,
10791 Defining_Unit_Name => PB_Ent),
10792 Declarations => Declarations (Acc_Stm),
10793 Handled_Statement_Sequence =>
10794 Build_Accept_Body (Accept_Statement (Alt)));
10795
10796 -- During the analysis of the body of the accept statement, any
10797 -- zero cost exception handler records were collected in the
10798 -- Accept_Handler_Records field of the N_Accept_Alternative node.
10799 -- This is where we move them to where they belong, namely the
10800 -- newly created procedure.
10801
10802 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt));
10803 Append (Proc_Body, Body_List);
10804
10805 else
10806 Null_Body := New_Occurrence_Of (Standard_True, Eloc);
10807
10808 -- if accept statement has declarations, insert above, given that
10809 -- we are not creating a body for the accept.
10810
10811 if Present (Declarations (Acc_Stm)) then
10812 Insert_Actions (N, Declarations (Acc_Stm));
10813 end if;
10814 end if;
10815
10816 Append_To (Accept_List,
10817 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr)));
10818
10819 Num_Accept := Num_Accept + 1;
10820 end Add_Accept;
10821
10822 ----------------------------
10823 -- Make_And_Declare_Label --
10824 ----------------------------
10825
10826 function Make_And_Declare_Label (Num : Int) return Node_Id is
10827 Lab_Id : Node_Id;
10828
10829 begin
10830 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num));
10831 Lab :=
10832 Make_Label (Loc, Lab_Id);
10833
10834 Append_To (Decls,
10835 Make_Implicit_Label_Declaration (Loc,
10836 Defining_Identifier =>
10837 Make_Defining_Identifier (Loc, Chars (Lab_Id)),
10838 Label_Construct => Lab));
10839
10840 return Lab;
10841 end Make_And_Declare_Label;
10842
10843 ----------------------
10844 -- Make_Select_Call --
10845 ----------------------
10846
10847 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is
10848 Params : constant List_Id := New_List;
10849
10850 begin
10851 Append_To (Params,
10852 Make_Attribute_Reference (Loc,
10853 Prefix => New_Occurrence_Of (Qnam, Loc),
10854 Attribute_Name => Name_Unchecked_Access));
10855 Append_To (Params, Select_Mode);
10856 Append_To (Params, New_Occurrence_Of (Ann, Loc));
10857 Append_To (Params, New_Occurrence_Of (Xnam, Loc));
10858
10859 return
10860 Make_Procedure_Call_Statement (Loc,
10861 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc),
10862 Parameter_Associations => Params);
10863 end Make_Select_Call;
10864
10865 --------------------------------
10866 -- Process_Accept_Alternative --
10867 --------------------------------
10868
10869 procedure Process_Accept_Alternative
10870 (Alt : Node_Id;
10871 Index : Int;
10872 Proc : Node_Id)
10873 is
10874 Astmt : constant Node_Id := Accept_Statement (Alt);
10875 Alt_Stats : List_Id;
10876
10877 begin
10878 Adjust_Condition (Condition (Alt));
10879
10880 -- Accept with body
10881
10882 if Present (Handled_Statement_Sequence (Astmt)) then
10883 Alt_Stats :=
10884 New_List (
10885 Make_Procedure_Call_Statement (Sloc (Proc),
10886 Name =>
10887 New_Occurrence_Of
10888 (Defining_Unit_Name (Specification (Proc)),
10889 Sloc (Proc))));
10890
10891 -- Accept with no body (followed by trailing statements)
10892
10893 else
10894 Alt_Stats := Empty_List;
10895 end if;
10896
10897 Ensure_Statement_Present (Sloc (Astmt), Alt);
10898
10899 -- After the call, if any, branch to trailing statements, if any.
10900 -- We create a label for each, as well as the corresponding label
10901 -- declaration.
10902
10903 if not Is_Empty_List (Statements (Alt)) then
10904 Lab := Make_And_Declare_Label (Index);
10905 Append (Lab, Trailing_List);
10906 Append_List (Statements (Alt), Trailing_List);
10907 Append_To (Trailing_List,
10908 Make_Goto_Statement (Loc,
10909 Name => New_Copy (Identifier (End_Lab))));
10910
10911 else
10912 Lab := End_Lab;
10913 end if;
10914
10915 Append_To (Alt_Stats,
10916 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab))));
10917
10918 Append_To (Alt_List,
10919 Make_Case_Statement_Alternative (Loc,
10920 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)),
10921 Statements => Alt_Stats));
10922 end Process_Accept_Alternative;
10923
10924 -------------------------------
10925 -- Process_Delay_Alternative --
10926 -------------------------------
10927
10928 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is
10929 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt));
10930 Cond : Node_Id;
10931 Delay_Alt : List_Id;
10932
10933 begin
10934 -- Deal with C/Fortran boolean as delay condition
10935
10936 Adjust_Condition (Condition (Alt));
10937
10938 -- Determine the smallest specified delay
10939
10940 -- for each delay alternative generate:
10941
10942 -- if guard-expression then
10943 -- Delay_Val := delay-expression;
10944 -- Guard_Open := True;
10945 -- if Delay_Val < Delay_Min then
10946 -- Delay_Min := Delay_Val;
10947 -- Delay_Index := Index;
10948 -- end if;
10949 -- end if;
10950
10951 -- The enclosing if-statement is omitted if there is no guard
10952
10953 if Delay_Count = 1 or else First_Delay then
10954 First_Delay := False;
10955
10956 Delay_Alt := New_List (
10957 Make_Assignment_Statement (Loc,
10958 Name => New_Occurrence_Of (Delay_Min, Loc),
10959 Expression => Expression (Delay_Statement (Alt))));
10960
10961 if Delay_Count > 1 then
10962 Append_To (Delay_Alt,
10963 Make_Assignment_Statement (Loc,
10964 Name => New_Occurrence_Of (Delay_Index, Loc),
10965 Expression => Make_Integer_Literal (Loc, Index)));
10966 end if;
10967
10968 else
10969 Delay_Alt := New_List (
10970 Make_Assignment_Statement (Loc,
10971 Name => New_Occurrence_Of (Delay_Val, Loc),
10972 Expression => Expression (Delay_Statement (Alt))));
10973
10974 if Time_Type = Standard_Duration then
10975 Cond :=
10976 Make_Op_Lt (Loc,
10977 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc),
10978 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc));
10979
10980 else
10981 -- The scope of the time type must define a comparison
10982 -- operator. The scope itself may not be visible, so we
10983 -- construct a node with entity information to insure that
10984 -- semantic analysis can find the proper operator.
10985
10986 Cond :=
10987 Make_Function_Call (Loc,
10988 Name => Make_Selected_Component (Loc,
10989 Prefix =>
10990 New_Occurrence_Of (Scope (Time_Type), Loc),
10991 Selector_Name =>
10992 Make_Operator_Symbol (Loc,
10993 Chars => Name_Op_Lt,
10994 Strval => No_String)),
10995 Parameter_Associations =>
10996 New_List (
10997 New_Occurrence_Of (Delay_Val, Loc),
10998 New_Occurrence_Of (Delay_Min, Loc)));
10999
11000 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type));
11001 end if;
11002
11003 Append_To (Delay_Alt,
11004 Make_Implicit_If_Statement (N,
11005 Condition => Cond,
11006 Then_Statements => New_List (
11007 Make_Assignment_Statement (Loc,
11008 Name => New_Occurrence_Of (Delay_Min, Loc),
11009 Expression => New_Occurrence_Of (Delay_Val, Loc)),
11010
11011 Make_Assignment_Statement (Loc,
11012 Name => New_Occurrence_Of (Delay_Index, Loc),
11013 Expression => Make_Integer_Literal (Loc, Index)))));
11014 end if;
11015
11016 if Check_Guard then
11017 Append_To (Delay_Alt,
11018 Make_Assignment_Statement (Loc,
11019 Name => New_Occurrence_Of (Guard_Open, Loc),
11020 Expression => New_Occurrence_Of (Standard_True, Loc)));
11021 end if;
11022
11023 if Present (Condition (Alt)) then
11024 Delay_Alt := New_List (
11025 Make_Implicit_If_Statement (N,
11026 Condition => Condition (Alt),
11027 Then_Statements => Delay_Alt));
11028 end if;
11029
11030 Append_List (Delay_Alt, Delay_List);
11031
11032 Ensure_Statement_Present (Dloc, Alt);
11033
11034 -- If the delay alternative has a statement part, add choice to the
11035 -- case statements for delays.
11036
11037 if not Is_Empty_List (Statements (Alt)) then
11038
11039 if Delay_Count = 1 then
11040 Append_List (Statements (Alt), Delay_Alt_List);
11041
11042 else
11043 Append_To (Delay_Alt_List,
11044 Make_Case_Statement_Alternative (Loc,
11045 Discrete_Choices => New_List (
11046 Make_Integer_Literal (Loc, Index)),
11047 Statements => Statements (Alt)));
11048 end if;
11049
11050 elsif Delay_Count = 1 then
11051
11052 -- If the single delay has no trailing statements, add a branch
11053 -- to the exit label to the selective wait.
11054
11055 Delay_Alt_List := New_List (
11056 Make_Goto_Statement (Loc,
11057 Name => New_Copy (Identifier (End_Lab))));
11058
11059 end if;
11060 end Process_Delay_Alternative;
11061
11062 -- Start of processing for Expand_N_Selective_Accept
11063
11064 begin
11065 Process_Statements_For_Controlled_Objects (N);
11066
11067 -- First insert some declarations before the select. The first is:
11068
11069 -- Ann : Address
11070
11071 -- This variable holds the parameters passed to the accept body. This
11072 -- declaration has already been inserted by the time we get here by
11073 -- a call to Expand_Accept_Declarations made from the semantics when
11074 -- processing the first accept statement contained in the select. We
11075 -- can find this entity as Accept_Address (E), where E is any of the
11076 -- entries references by contained accept statements.
11077
11078 -- The first step is to scan the list of Selective_Accept_Statements
11079 -- to find this entity, and also count the number of accepts, and
11080 -- determine if terminated, delay or else is present:
11081
11082 Num_Alts := 0;
11083
11084 Alt := First (Alts);
11085 while Present (Alt) loop
11086 Process_Statements_For_Controlled_Objects (Alt);
11087
11088 if Nkind (Alt) = N_Accept_Alternative then
11089 Add_Accept (Alt);
11090
11091 elsif Nkind (Alt) = N_Delay_Alternative then
11092 Delay_Count := Delay_Count + 1;
11093
11094 -- If the delays are relative delays, the delay expressions have
11095 -- type Standard_Duration. Otherwise they must have some time type
11096 -- recognized by GNAT.
11097
11098 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then
11099 Time_Type := Standard_Duration;
11100 else
11101 Time_Type := Etype (Expression (Delay_Statement (Alt)));
11102
11103 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time)
11104 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)
11105 then
11106 null;
11107 else
11108 Error_Msg_NE (
11109 "& is not a time type (RM 9.6(6))",
11110 Expression (Delay_Statement (Alt)), Time_Type);
11111 Time_Type := Standard_Duration;
11112 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type);
11113 end if;
11114 end if;
11115
11116 if No (Condition (Alt)) then
11117
11118 -- This guard will always be open
11119
11120 Check_Guard := False;
11121 end if;
11122
11123 elsif Nkind (Alt) = N_Terminate_Alternative then
11124 Adjust_Condition (Condition (Alt));
11125 Terminate_Alt := Alt;
11126 end if;
11127
11128 Num_Alts := Num_Alts + 1;
11129 Next (Alt);
11130 end loop;
11131
11132 Else_Present := Present (Else_Statements (N));
11133
11134 -- At the same time (see procedure Add_Accept) we build the accept list:
11135
11136 -- Qnn : Accept_List (1 .. num-select) := (
11137 -- (null-body, entry-index),
11138 -- (null-body, entry-index),
11139 -- ..
11140 -- (null_body, entry-index));
11141
11142 -- In the above declaration, null-body is True if the corresponding
11143 -- accept has no body, and false otherwise. The entry is either the
11144 -- entry index expression if there is no guard, or if a guard is
11145 -- present, then an if expression of the form:
11146
11147 -- (if guard then entry-index else Null_Task_Entry)
11148
11149 -- If a guard is statically known to be false, the entry can simply
11150 -- be omitted from the accept list.
11151
11152 Append_To (Decls,
11153 Make_Object_Declaration (Loc,
11154 Defining_Identifier => Qnam,
11155 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc),
11156 Aliased_Present => True,
11157 Expression =>
11158 Make_Qualified_Expression (Loc,
11159 Subtype_Mark =>
11160 New_Occurrence_Of (RTE (RE_Accept_List), Loc),
11161 Expression =>
11162 Make_Aggregate (Loc, Expressions => Accept_List))));
11163
11164 -- Then we declare the variable that holds the index for the accept
11165 -- that will be selected for service:
11166
11167 -- Xnn : Select_Index;
11168
11169 Append_To (Decls,
11170 Make_Object_Declaration (Loc,
11171 Defining_Identifier => Xnam,
11172 Object_Definition =>
11173 New_Occurrence_Of (RTE (RE_Select_Index), Loc),
11174 Expression =>
11175 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)));
11176
11177 -- After this follow procedure declarations for each accept body
11178
11179 -- procedure Pnn is
11180 -- begin
11181 -- ...
11182 -- end;
11183
11184 -- where the ... are statements from the corresponding procedure body.
11185 -- No parameters are involved, since the parameters are passed via Ann
11186 -- and the parameter references have already been expanded to be direct
11187 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore,
11188 -- any embedded tasking statements (which would normally be illegal in
11189 -- procedures), have been converted to calls to the tasking runtime so
11190 -- there is no problem in putting them into procedures.
11191
11192 -- The original accept statement has been expanded into a block in
11193 -- the same fashion as for simple accepts (see Build_Accept_Body).
11194
11195 -- Note: we don't really need to build these procedures for the case
11196 -- where no delay statement is present, but it is just as easy to
11197 -- build them unconditionally, and not significantly inefficient,
11198 -- since if they are short they will be inlined anyway.
11199
11200 -- The procedure declarations have been assembled in Body_List
11201
11202 -- If delays are present, we must compute the required delay.
11203 -- We first generate the declarations:
11204
11205 -- Delay_Index : Boolean := 0;
11206 -- Delay_Min : Some_Time_Type.Time;
11207 -- Delay_Val : Some_Time_Type.Time;
11208
11209 -- Delay_Index will be set to the index of the minimum delay, i.e. the
11210 -- active delay that is actually chosen as the basis for the possible
11211 -- delay if an immediate rendez-vous is not possible.
11212
11213 -- In the most common case there is a single delay statement, and this
11214 -- is handled specially.
11215
11216 if Delay_Count > 0 then
11217
11218 -- Generate the required declarations
11219
11220 Delay_Val :=
11221 Make_Defining_Identifier (Loc, New_External_Name ('D', 1));
11222 Delay_Index :=
11223 Make_Defining_Identifier (Loc, New_External_Name ('D', 2));
11224 Delay_Min :=
11225 Make_Defining_Identifier (Loc, New_External_Name ('D', 3));
11226
11227 Append_To (Decls,
11228 Make_Object_Declaration (Loc,
11229 Defining_Identifier => Delay_Val,
11230 Object_Definition => New_Occurrence_Of (Time_Type, Loc)));
11231
11232 Append_To (Decls,
11233 Make_Object_Declaration (Loc,
11234 Defining_Identifier => Delay_Index,
11235 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
11236 Expression => Make_Integer_Literal (Loc, 0)));
11237
11238 Append_To (Decls,
11239 Make_Object_Declaration (Loc,
11240 Defining_Identifier => Delay_Min,
11241 Object_Definition => New_Occurrence_Of (Time_Type, Loc),
11242 Expression =>
11243 Unchecked_Convert_To (Time_Type,
11244 Make_Attribute_Reference (Loc,
11245 Prefix =>
11246 New_Occurrence_Of (Underlying_Type (Time_Type), Loc),
11247 Attribute_Name => Name_Last))));
11248
11249 -- Create Duration and Delay_Mode objects used for passing a delay
11250 -- value to RTS
11251
11252 D := Make_Temporary (Loc, 'D');
11253 M := Make_Temporary (Loc, 'M');
11254
11255 declare
11256 Discr : Entity_Id;
11257
11258 begin
11259 -- Note that these values are defined in s-osprim.ads and must
11260 -- be kept in sync:
11261 --
11262 -- Relative : constant := 0;
11263 -- Absolute_Calendar : constant := 1;
11264 -- Absolute_RT : constant := 2;
11265
11266 if Time_Type = Standard_Duration then
11267 Discr := Make_Integer_Literal (Loc, 0);
11268
11269 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
11270 Discr := Make_Integer_Literal (Loc, 1);
11271
11272 else
11273 pragma Assert
11274 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
11275 Discr := Make_Integer_Literal (Loc, 2);
11276 end if;
11277
11278 Append_To (Decls,
11279 Make_Object_Declaration (Loc,
11280 Defining_Identifier => D,
11281 Object_Definition =>
11282 New_Occurrence_Of (Standard_Duration, Loc)));
11283
11284 Append_To (Decls,
11285 Make_Object_Declaration (Loc,
11286 Defining_Identifier => M,
11287 Object_Definition =>
11288 New_Occurrence_Of (Standard_Integer, Loc),
11289 Expression => Discr));
11290 end;
11291
11292 if Check_Guard then
11293 Guard_Open :=
11294 Make_Defining_Identifier (Loc, New_External_Name ('G', 1));
11295
11296 Append_To (Decls,
11297 Make_Object_Declaration (Loc,
11298 Defining_Identifier => Guard_Open,
11299 Object_Definition =>
11300 New_Occurrence_Of (Standard_Boolean, Loc),
11301 Expression =>
11302 New_Occurrence_Of (Standard_False, Loc)));
11303 end if;
11304
11305 -- Delay_Count is zero, don't need M and D set (suppress warning)
11306
11307 else
11308 M := Empty;
11309 D := Empty;
11310 end if;
11311
11312 if Present (Terminate_Alt) then
11313
11314 -- If the terminate alternative guard is False, use
11315 -- Simple_Mode; otherwise use Terminate_Mode.
11316
11317 if Present (Condition (Terminate_Alt)) then
11318 Select_Mode := Make_If_Expression (Loc,
11319 New_List (Condition (Terminate_Alt),
11320 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc),
11321 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)));
11322 else
11323 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc);
11324 end if;
11325
11326 elsif Else_Present or Delay_Count > 0 then
11327 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc);
11328
11329 else
11330 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc);
11331 end if;
11332
11333 Select_Call := Make_Select_Call (Select_Mode);
11334 Append (Select_Call, Stats);
11335
11336 -- Now generate code to act on the result. There is an entry
11337 -- in this case for each accept statement with a non-null body,
11338 -- followed by a branch to the statements that follow the Accept.
11339 -- In the absence of delay alternatives, we generate:
11340
11341 -- case X is
11342 -- when No_Rendezvous => -- omitted if simple mode
11343 -- goto Lab0;
11344
11345 -- when 1 =>
11346 -- P1n;
11347 -- goto Lab1;
11348
11349 -- when 2 =>
11350 -- P2n;
11351 -- goto Lab2;
11352
11353 -- when others =>
11354 -- goto Exit;
11355 -- end case;
11356 --
11357 -- Lab0: Else_Statements;
11358 -- goto exit;
11359
11360 -- Lab1: Trailing_Statements1;
11361 -- goto Exit;
11362 --
11363 -- Lab2: Trailing_Statements2;
11364 -- goto Exit;
11365 -- ...
11366 -- Exit:
11367
11368 -- Generate label for common exit
11369
11370 End_Lab := Make_And_Declare_Label (Num_Alts + 1);
11371
11372 -- First entry is the default case, when no rendezvous is possible
11373
11374 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc));
11375
11376 if Else_Present then
11377
11378 -- If no rendezvous is possible, the else part is executed
11379
11380 Lab := Make_And_Declare_Label (0);
11381 Alt_Stats := New_List (
11382 Make_Goto_Statement (Loc,
11383 Name => New_Copy (Identifier (Lab))));
11384
11385 Append (Lab, Trailing_List);
11386 Append_List (Else_Statements (N), Trailing_List);
11387 Append_To (Trailing_List,
11388 Make_Goto_Statement (Loc,
11389 Name => New_Copy (Identifier (End_Lab))));
11390 else
11391 Alt_Stats := New_List (
11392 Make_Goto_Statement (Loc,
11393 Name => New_Copy (Identifier (End_Lab))));
11394 end if;
11395
11396 Append_To (Alt_List,
11397 Make_Case_Statement_Alternative (Loc,
11398 Discrete_Choices => Choices,
11399 Statements => Alt_Stats));
11400
11401 -- We make use of the fact that Accept_Index is an integer type, and
11402 -- generate successive literals for entries for each accept. Only those
11403 -- for which there is a body or trailing statements get a case entry.
11404
11405 Alt := First (Select_Alternatives (N));
11406 Proc := First (Body_List);
11407 while Present (Alt) loop
11408
11409 if Nkind (Alt) = N_Accept_Alternative then
11410 Process_Accept_Alternative (Alt, Index, Proc);
11411 Index := Index + 1;
11412
11413 if Present
11414 (Handled_Statement_Sequence (Accept_Statement (Alt)))
11415 then
11416 Next (Proc);
11417 end if;
11418
11419 elsif Nkind (Alt) = N_Delay_Alternative then
11420 Process_Delay_Alternative (Alt, Delay_Num);
11421 Delay_Num := Delay_Num + 1;
11422 end if;
11423
11424 Next (Alt);
11425 end loop;
11426
11427 -- An others choice is always added to the main case, as well
11428 -- as the delay case (to satisfy the compiler).
11429
11430 Append_To (Alt_List,
11431 Make_Case_Statement_Alternative (Loc,
11432 Discrete_Choices =>
11433 New_List (Make_Others_Choice (Loc)),
11434 Statements =>
11435 New_List (Make_Goto_Statement (Loc,
11436 Name => New_Copy (Identifier (End_Lab))))));
11437
11438 Accept_Case := New_List (
11439 Make_Case_Statement (Loc,
11440 Expression => New_Occurrence_Of (Xnam, Loc),
11441 Alternatives => Alt_List));
11442
11443 Append_List (Trailing_List, Accept_Case);
11444 Append_List (Body_List, Decls);
11445
11446 -- Construct case statement for trailing statements of delay
11447 -- alternatives, if there are several of them.
11448
11449 if Delay_Count > 1 then
11450 Append_To (Delay_Alt_List,
11451 Make_Case_Statement_Alternative (Loc,
11452 Discrete_Choices =>
11453 New_List (Make_Others_Choice (Loc)),
11454 Statements =>
11455 New_List (Make_Null_Statement (Loc))));
11456
11457 Delay_Case := New_List (
11458 Make_Case_Statement (Loc,
11459 Expression => New_Occurrence_Of (Delay_Index, Loc),
11460 Alternatives => Delay_Alt_List));
11461 else
11462 Delay_Case := Delay_Alt_List;
11463 end if;
11464
11465 -- If there are no delay alternatives, we append the case statement
11466 -- to the statement list.
11467
11468 if Delay_Count = 0 then
11469 Append_List (Accept_Case, Stats);
11470
11471 -- Delay alternatives present
11472
11473 else
11474 -- If delay alternatives are present we generate:
11475
11476 -- find minimum delay.
11477 -- DX := minimum delay;
11478 -- M := <delay mode>;
11479 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P,
11480 -- DX, MX, X);
11481 --
11482 -- if X = No_Rendezvous then
11483 -- case statement for delay statements.
11484 -- else
11485 -- case statement for accept alternatives.
11486 -- end if;
11487
11488 declare
11489 Cases : Node_Id;
11490 Stmt : Node_Id;
11491 Parms : List_Id;
11492 Parm : Node_Id;
11493 Conv : Node_Id;
11494
11495 begin
11496 -- The type of the delay expression is known to be legal
11497
11498 if Time_Type = Standard_Duration then
11499 Conv := New_Occurrence_Of (Delay_Min, Loc);
11500
11501 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then
11502 Conv := Make_Function_Call (Loc,
11503 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc),
11504 New_List (New_Occurrence_Of (Delay_Min, Loc)));
11505
11506 else
11507 pragma Assert
11508 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time));
11509
11510 Conv := Make_Function_Call (Loc,
11511 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
11512 New_List (New_Occurrence_Of (Delay_Min, Loc)));
11513 end if;
11514
11515 Stmt := Make_Assignment_Statement (Loc,
11516 Name => New_Occurrence_Of (D, Loc),
11517 Expression => Conv);
11518
11519 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode)
11520
11521 Parms := Parameter_Associations (Select_Call);
11522
11523 Parm := First (Parms);
11524 while Present (Parm) and then Parm /= Select_Mode loop
11525 Next (Parm);
11526 end loop;
11527
11528 pragma Assert (Present (Parm));
11529 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc));
11530 Analyze (Parm);
11531
11532 -- Prepare two new parameters of Duration and Delay_Mode type
11533 -- which represent the value and the mode of the minimum delay.
11534
11535 Next (Parm);
11536 Insert_After (Parm, New_Occurrence_Of (M, Loc));
11537 Insert_After (Parm, New_Occurrence_Of (D, Loc));
11538
11539 -- Create a call to RTS
11540
11541 Rewrite (Select_Call,
11542 Make_Procedure_Call_Statement (Loc,
11543 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc),
11544 Parameter_Associations => Parms));
11545
11546 -- This new call should follow the calculation of the minimum
11547 -- delay.
11548
11549 Insert_List_Before (Select_Call, Delay_List);
11550
11551 if Check_Guard then
11552 Stmt :=
11553 Make_Implicit_If_Statement (N,
11554 Condition => New_Occurrence_Of (Guard_Open, Loc),
11555 Then_Statements => New_List (
11556 New_Copy_Tree (Stmt),
11557 New_Copy_Tree (Select_Call)),
11558 Else_Statements => Accept_Or_Raise);
11559 Rewrite (Select_Call, Stmt);
11560 else
11561 Insert_Before (Select_Call, Stmt);
11562 end if;
11563
11564 Cases :=
11565 Make_Implicit_If_Statement (N,
11566 Condition => Make_Op_Eq (Loc,
11567 Left_Opnd => New_Occurrence_Of (Xnam, Loc),
11568 Right_Opnd =>
11569 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)),
11570
11571 Then_Statements => Delay_Case,
11572 Else_Statements => Accept_Case);
11573
11574 Append (Cases, Stats);
11575 end;
11576 end if;
11577
11578 Append (End_Lab, Stats);
11579
11580 -- Replace accept statement with appropriate block
11581
11582 Rewrite (N,
11583 Make_Block_Statement (Loc,
11584 Declarations => Decls,
11585 Handled_Statement_Sequence =>
11586 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats)));
11587 Analyze (N);
11588
11589 -- Note: have to worry more about abort deferral in above code ???
11590
11591 -- Final step is to unstack the Accept_Address entries for all accept
11592 -- statements appearing in accept alternatives in the select statement
11593
11594 Alt := First (Alts);
11595 while Present (Alt) loop
11596 if Nkind (Alt) = N_Accept_Alternative then
11597 Remove_Last_Elmt (Accept_Address
11598 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))));
11599 end if;
11600
11601 Next (Alt);
11602 end loop;
11603 end Expand_N_Selective_Accept;
11604
11605 -------------------------------------------
11606 -- Expand_N_Single_Protected_Declaration --
11607 -------------------------------------------
11608
11609 -- A single protected declaration should never be present after semantic
11610 -- analysis because it is transformed into a protected type declaration
11611 -- and an accompanying anonymous object. This routine ensures that the
11612 -- transformation takes place.
11613
11614 procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is
11615 begin
11616 raise Program_Error;
11617 end Expand_N_Single_Protected_Declaration;
11618
11619 --------------------------------------
11620 -- Expand_N_Single_Task_Declaration --
11621 --------------------------------------
11622
11623 -- A single task declaration should never be present after semantic
11624 -- analysis because it is transformed into a task type declaration and
11625 -- an accompanying anonymous object. This routine ensures that the
11626 -- transformation takes place.
11627
11628 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is
11629 begin
11630 raise Program_Error;
11631 end Expand_N_Single_Task_Declaration;
11632
11633 ------------------------
11634 -- Expand_N_Task_Body --
11635 ------------------------
11636
11637 -- Given a task body
11638
11639 -- task body tname is
11640 -- <declarations>
11641 -- begin
11642 -- <statements>
11643 -- end x;
11644
11645 -- This expansion routine converts it into a procedure and sets the
11646 -- elaboration flag for the procedure to true, to represent the fact
11647 -- that the task body is now elaborated:
11648
11649 -- procedure tnameB (_Task : access tnameV) is
11650 -- discriminal : dtype renames _Task.discriminant;
11651
11652 -- procedure _clean is
11653 -- begin
11654 -- Abort_Defer.all;
11655 -- Complete_Task;
11656 -- Abort_Undefer.all;
11657 -- return;
11658 -- end _clean;
11659
11660 -- begin
11661 -- Abort_Undefer.all;
11662 -- <declarations>
11663 -- System.Task_Stages.Complete_Activation;
11664 -- <statements>
11665 -- at end
11666 -- _clean;
11667 -- end tnameB;
11668
11669 -- tnameE := True;
11670
11671 -- In addition, if the task body is an activator, then a call to activate
11672 -- tasks is added at the start of the statements, before the call to
11673 -- Complete_Activation, and if in addition the task is a master then it
11674 -- must be established as a master. These calls are inserted and analyzed
11675 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is
11676 -- expanded.
11677
11678 -- There is one discriminal declaration line generated for each
11679 -- discriminant that is present to provide an easy reference point for
11680 -- discriminant references inside the body (see Exp_Ch2.Expand_Name).
11681
11682 -- Note on relationship to GNARLI definition. In the GNARLI definition,
11683 -- task body procedures have a profile (Arg : System.Address). That is
11684 -- needed because GNARLI has to use the same access-to-subprogram type
11685 -- for all task types. We depend here on knowing that in GNAT, passing
11686 -- an address argument by value is identical to passing a record value
11687 -- by access (in either case a single pointer is passed), so even though
11688 -- this procedure has the wrong profile. In fact it's all OK, since the
11689 -- callings sequence is identical.
11690
11691 procedure Expand_N_Task_Body (N : Node_Id) is
11692 Loc : constant Source_Ptr := Sloc (N);
11693 Ttyp : constant Entity_Id := Corresponding_Spec (N);
11694 Call : Node_Id;
11695 New_N : Node_Id;
11696
11697 Insert_Nod : Node_Id;
11698 -- Used to determine the proper location of wrapper body insertions
11699
11700 begin
11701 -- if no task body procedure, means we had an error in configurable
11702 -- run-time mode, and there is no point in proceeding further.
11703
11704 if No (Task_Body_Procedure (Ttyp)) then
11705 return;
11706 end if;
11707
11708 -- Add renaming declarations for discriminals and a declaration for the
11709 -- entry family index (if applicable).
11710
11711 Install_Private_Data_Declarations
11712 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N));
11713
11714 -- Add a call to Abort_Undefer at the very beginning of the task
11715 -- body since this body is called with abort still deferred.
11716
11717 if Abort_Allowed then
11718 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer);
11719 Insert_Before
11720 (First (Statements (Handled_Statement_Sequence (N))), Call);
11721 Analyze (Call);
11722 end if;
11723
11724 -- The statement part has already been protected with an at_end and
11725 -- cleanup actions. The call to Complete_Activation must be placed
11726 -- at the head of the sequence of statements of that block. The
11727 -- declarations have been merged in this sequence of statements but
11728 -- the first real statement is accessible from the First_Real_Statement
11729 -- field (which was set for exactly this purpose).
11730
11731 if Restricted_Profile then
11732 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation);
11733 else
11734 Call := Build_Runtime_Call (Loc, RE_Complete_Activation);
11735 end if;
11736
11737 Insert_Before
11738 (First_Real_Statement (Handled_Statement_Sequence (N)), Call);
11739 Analyze (Call);
11740
11741 New_N :=
11742 Make_Subprogram_Body (Loc,
11743 Specification => Build_Task_Proc_Specification (Ttyp),
11744 Declarations => Declarations (N),
11745 Handled_Statement_Sequence => Handled_Statement_Sequence (N));
11746 Set_Is_Task_Body_Procedure (New_N);
11747
11748 -- If the task contains generic instantiations, cleanup actions are
11749 -- delayed until after instantiation. Transfer the activation chain to
11750 -- the subprogram, to insure that the activation call is properly
11751 -- generated. It the task body contains inner tasks, indicate that the
11752 -- subprogram is a task master.
11753
11754 if Delay_Cleanups (Ttyp) then
11755 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N));
11756 Set_Is_Task_Master (New_N, Is_Task_Master (N));
11757 end if;
11758
11759 Rewrite (N, New_N);
11760 Analyze (N);
11761
11762 -- Set elaboration flag immediately after task body. If the body is a
11763 -- subunit, the flag is set in the declarative part containing the stub.
11764
11765 if Nkind (Parent (N)) /= N_Subunit then
11766 Insert_After (N,
11767 Make_Assignment_Statement (Loc,
11768 Name =>
11769 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')),
11770 Expression => New_Occurrence_Of (Standard_True, Loc)));
11771 end if;
11772
11773 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after
11774 -- the task body. At this point all wrapper specs have been created,
11775 -- frozen and included in the dispatch table for the task type.
11776
11777 if Ada_Version >= Ada_2005 then
11778 if Nkind (Parent (N)) = N_Subunit then
11779 Insert_Nod := Corresponding_Stub (Parent (N));
11780 else
11781 Insert_Nod := N;
11782 end if;
11783
11784 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod);
11785 end if;
11786 end Expand_N_Task_Body;
11787
11788 ------------------------------------
11789 -- Expand_N_Task_Type_Declaration --
11790 ------------------------------------
11791
11792 -- We have several things to do. First we must create a Boolean flag used
11793 -- to mark if the body is elaborated yet. This variable gets set to True
11794 -- when the body of the task is elaborated (we can't rely on the normal
11795 -- ABE mechanism for the task body, since we need to pass an access to
11796 -- this elaboration boolean to the runtime routines).
11797
11798 -- taskE : aliased Boolean := False;
11799
11800 -- Next a variable is declared to hold the task stack size (either the
11801 -- default : Unspecified_Size, or a value that is set by a pragma
11802 -- Storage_Size). If the value of the pragma Storage_Size is static, then
11803 -- the variable is initialized with this value:
11804
11805 -- taskZ : Size_Type := Unspecified_Size;
11806 -- or
11807 -- taskZ : Size_Type := Size_Type (size_expression);
11808
11809 -- Note: No variable is needed to hold the task relative deadline since
11810 -- its value would never be static because the parameter is of a private
11811 -- type (Ada.Real_Time.Time_Span).
11812
11813 -- Next we create a corresponding record type declaration used to represent
11814 -- values of this task. The general form of this type declaration is
11815
11816 -- type taskV (discriminants) is record
11817 -- _Task_Id : Task_Id;
11818 -- entry_family : array (bounds) of Void;
11819 -- _Priority : Integer := priority_expression;
11820 -- _Size : Size_Type := size_expression;
11821 -- _Task_Info : Task_Info_Type := task_info_expression;
11822 -- _CPU : Integer := cpu_range_expression;
11823 -- _Relative_Deadline : Time_Span := time_span_expression;
11824 -- _Domain : Dispatching_Domain := dd_expression;
11825 -- end record;
11826
11827 -- The discriminants are present only if the corresponding task type has
11828 -- discriminants, and they exactly mirror the task type discriminants.
11829
11830 -- The Id field is always present. It contains the Task_Id value, as set by
11831 -- the call to Create_Task. Note that although the task is limited, the
11832 -- task value record type is not limited, so there is no problem in passing
11833 -- this field as an out parameter to Create_Task.
11834
11835 -- One entry_family component is present for each entry family in the task
11836 -- definition. The bounds correspond to the bounds of the entry family
11837 -- (which may depend on discriminants). The element type is void, since we
11838 -- only need the bounds information for determining the entry index. Note
11839 -- that the use of an anonymous array would normally be illegal in this
11840 -- context, but this is a parser check, and the semantics is quite prepared
11841 -- to handle such a case.
11842
11843 -- The _Size field is present only if a Storage_Size pragma appears in the
11844 -- task definition. The expression captures the argument that was present
11845 -- in the pragma, and is used to override the task stack size otherwise
11846 -- associated with the task type.
11847
11848 -- The _Priority field is present only if the task entity has a Priority or
11849 -- Interrupt_Priority rep item (pragma, aspect specification or attribute
11850 -- definition clause). It will be filled at the freeze point, when the
11851 -- record init proc is built, to capture the expression of the rep item
11852 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11853 -- here since aspect evaluations are delayed till the freeze point.
11854
11855 -- The _Task_Info field is present only if a Task_Info pragma appears in
11856 -- the task definition. The expression captures the argument that was
11857 -- present in the pragma, and is used to provide the Task_Image parameter
11858 -- to the call to Create_Task.
11859
11860 -- The _CPU field is present only if the task entity has a CPU rep item
11861 -- (pragma, aspect specification or attribute definition clause). It will
11862 -- be filled at the freeze point, when the record init proc is built, to
11863 -- capture the expression of the rep item (see Build_Record_Init_Proc in
11864 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
11865 -- are delayed till the freeze point.
11866
11867 -- The _Relative_Deadline field is present only if a Relative_Deadline
11868 -- pragma appears in the task definition. The expression captures the
11869 -- argument that was present in the pragma, and is used to provide the
11870 -- Relative_Deadline parameter to the call to Create_Task.
11871
11872 -- The _Domain field is present only if the task entity has a
11873 -- Dispatching_Domain rep item (pragma, aspect specification or attribute
11874 -- definition clause). It will be filled at the freeze point, when the
11875 -- record init proc is built, to capture the expression of the rep item
11876 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
11877 -- here since aspect evaluations are delayed till the freeze point.
11878
11879 -- When a task is declared, an instance of the task value record is
11880 -- created. The elaboration of this declaration creates the correct bounds
11881 -- for the entry families, and also evaluates the size, priority, and
11882 -- task_Info expressions if needed. The initialization routine for the task
11883 -- type itself then calls Create_Task with appropriate parameters to
11884 -- initialize the value of the Task_Id field.
11885
11886 -- Note: the address of this record is passed as the "Discriminants"
11887 -- parameter for Create_Task. Since Create_Task merely passes this onto the
11888 -- body procedure, it does not matter that it does not quite match the
11889 -- GNARLI model of what is being passed (the record contains more than just
11890 -- the discriminants, but the discriminants can be found from the record
11891 -- value).
11892
11893 -- The Entity_Id for this created record type is placed in the
11894 -- Corresponding_Record_Type field of the associated task type entity.
11895
11896 -- Next we create a procedure specification for the task body procedure:
11897
11898 -- procedure taskB (_Task : access taskV);
11899
11900 -- Note that this must come after the record type declaration, since
11901 -- the spec refers to this type. It turns out that the initialization
11902 -- procedure for the value type references the task body spec, but that's
11903 -- fine, since it won't be generated till the freeze point for the type,
11904 -- which is certainly after the task body spec declaration.
11905
11906 -- Finally, we set the task index value field of the entry attribute in
11907 -- the case of a simple entry.
11908
11909 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is
11910 Loc : constant Source_Ptr := Sloc (N);
11911 TaskId : constant Entity_Id := Defining_Identifier (N);
11912 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N));
11913 Tasknm : constant Name_Id := Chars (Tasktyp);
11914 Taskdef : constant Node_Id := Task_Definition (N);
11915
11916 Body_Decl : Node_Id;
11917 Cdecls : List_Id;
11918 Decl_Stack : Node_Id;
11919 Elab_Decl : Node_Id;
11920 Ent_Stack : Entity_Id;
11921 Proc_Spec : Node_Id;
11922 Rec_Decl : Node_Id;
11923 Rec_Ent : Entity_Id;
11924 Size_Decl : Entity_Id;
11925 Task_Size : Node_Id;
11926
11927 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id;
11928 -- Searches the task definition T for the first occurrence of the pragma
11929 -- Relative Deadline. The caller has ensured that the pragma is present
11930 -- in the task definition. Note that this routine cannot be implemented
11931 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
11932 -- not chained because their expansion into a procedure call statement
11933 -- would cause a break in the chain.
11934
11935 ----------------------------------
11936 -- Get_Relative_Deadline_Pragma --
11937 ----------------------------------
11938
11939 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is
11940 N : Node_Id;
11941
11942 begin
11943 N := First (Visible_Declarations (T));
11944 while Present (N) loop
11945 if Nkind (N) = N_Pragma
11946 and then Pragma_Name (N) = Name_Relative_Deadline
11947 then
11948 return N;
11949 end if;
11950
11951 Next (N);
11952 end loop;
11953
11954 N := First (Private_Declarations (T));
11955 while Present (N) loop
11956 if Nkind (N) = N_Pragma
11957 and then Pragma_Name (N) = Name_Relative_Deadline
11958 then
11959 return N;
11960 end if;
11961
11962 Next (N);
11963 end loop;
11964
11965 raise Program_Error;
11966 end Get_Relative_Deadline_Pragma;
11967
11968 -- Start of processing for Expand_N_Task_Type_Declaration
11969
11970 begin
11971 -- If already expanded, nothing to do
11972
11973 if Present (Corresponding_Record_Type (Tasktyp)) then
11974 return;
11975 end if;
11976
11977 -- Here we will do the expansion
11978
11979 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
11980
11981 Rec_Ent := Defining_Identifier (Rec_Decl);
11982 Cdecls := Component_Items (Component_List
11983 (Type_Definition (Rec_Decl)));
11984
11985 Qualify_Entity_Names (N);
11986
11987 -- First create the elaboration variable
11988
11989 Elab_Decl :=
11990 Make_Object_Declaration (Loc,
11991 Defining_Identifier =>
11992 Make_Defining_Identifier (Sloc (Tasktyp),
11993 Chars => New_External_Name (Tasknm, 'E')),
11994 Aliased_Present => True,
11995 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
11996 Expression => New_Occurrence_Of (Standard_False, Loc));
11997
11998 Insert_After (N, Elab_Decl);
11999
12000 -- Next create the declaration of the size variable (tasknmZ)
12001
12002 Set_Storage_Size_Variable (Tasktyp,
12003 Make_Defining_Identifier (Sloc (Tasktyp),
12004 Chars => New_External_Name (Tasknm, 'Z')));
12005
12006 if Present (Taskdef)
12007 and then Has_Storage_Size_Pragma (Taskdef)
12008 and then
12009 Is_OK_Static_Expression
12010 (Expression
12011 (First (Pragma_Argument_Associations
12012 (Get_Rep_Pragma (TaskId, Name_Storage_Size)))))
12013 then
12014 Size_Decl :=
12015 Make_Object_Declaration (Loc,
12016 Defining_Identifier => Storage_Size_Variable (Tasktyp),
12017 Object_Definition =>
12018 New_Occurrence_Of (RTE (RE_Size_Type), Loc),
12019 Expression =>
12020 Convert_To (RTE (RE_Size_Type),
12021 Relocate_Node
12022 (Expression (First (Pragma_Argument_Associations
12023 (Get_Rep_Pragma
12024 (TaskId, Name_Storage_Size)))))));
12025
12026 else
12027 Size_Decl :=
12028 Make_Object_Declaration (Loc,
12029 Defining_Identifier => Storage_Size_Variable (Tasktyp),
12030 Object_Definition =>
12031 New_Occurrence_Of (RTE (RE_Size_Type), Loc),
12032 Expression =>
12033 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc));
12034 end if;
12035
12036 Insert_After (Elab_Decl, Size_Decl);
12037
12038 -- Next build the rest of the corresponding record declaration. This is
12039 -- done last, since the corresponding record initialization procedure
12040 -- will reference the previously created entities.
12041
12042 -- Fill in the component declarations -- first the _Task_Id field
12043
12044 Append_To (Cdecls,
12045 Make_Component_Declaration (Loc,
12046 Defining_Identifier =>
12047 Make_Defining_Identifier (Loc, Name_uTask_Id),
12048 Component_Definition =>
12049 Make_Component_Definition (Loc,
12050 Aliased_Present => False,
12051 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id),
12052 Loc))));
12053
12054 -- Declare static ATCB (that is, created by the expander) if we are
12055 -- using the Restricted run time.
12056
12057 if Restricted_Profile then
12058 Append_To (Cdecls,
12059 Make_Component_Declaration (Loc,
12060 Defining_Identifier =>
12061 Make_Defining_Identifier (Loc, Name_uATCB),
12062
12063 Component_Definition =>
12064 Make_Component_Definition (Loc,
12065 Aliased_Present => True,
12066 Subtype_Indication => Make_Subtype_Indication (Loc,
12067 Subtype_Mark =>
12068 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc),
12069
12070 Constraint =>
12071 Make_Index_Or_Discriminant_Constraint (Loc,
12072 Constraints =>
12073 New_List (Make_Integer_Literal (Loc, 0)))))));
12074
12075 end if;
12076
12077 -- Declare static stack (that is, created by the expander) if we are
12078 -- using the Restricted run time on a bare board configuration.
12079
12080 if Restricted_Profile and then Preallocated_Stacks_On_Target then
12081
12082 -- First we need to extract the appropriate stack size
12083
12084 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack);
12085
12086 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
12087 declare
12088 Expr_N : constant Node_Id :=
12089 Expression (First (
12090 Pragma_Argument_Associations (
12091 Get_Rep_Pragma (TaskId, Name_Storage_Size))));
12092 Etyp : constant Entity_Id := Etype (Expr_N);
12093 P : constant Node_Id := Parent (Expr_N);
12094
12095 begin
12096 -- The stack is defined inside the corresponding record.
12097 -- Therefore if the size of the stack is set by means of
12098 -- a discriminant, we must reference the discriminant of the
12099 -- corresponding record type.
12100
12101 if Nkind (Expr_N) in N_Has_Entity
12102 and then Present (Discriminal_Link (Entity (Expr_N)))
12103 then
12104 Task_Size :=
12105 New_Occurrence_Of
12106 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))),
12107 Loc);
12108 Set_Parent (Task_Size, P);
12109 Set_Etype (Task_Size, Etyp);
12110 Set_Analyzed (Task_Size);
12111
12112 else
12113 Task_Size := Relocate_Node (Expr_N);
12114 end if;
12115 end;
12116
12117 else
12118 Task_Size :=
12119 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc);
12120 end if;
12121
12122 Decl_Stack := Make_Component_Declaration (Loc,
12123 Defining_Identifier => Ent_Stack,
12124
12125 Component_Definition =>
12126 Make_Component_Definition (Loc,
12127 Aliased_Present => True,
12128 Subtype_Indication => Make_Subtype_Indication (Loc,
12129 Subtype_Mark =>
12130 New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
12131
12132 Constraint =>
12133 Make_Index_Or_Discriminant_Constraint (Loc,
12134 Constraints => New_List (Make_Range (Loc,
12135 Low_Bound => Make_Integer_Literal (Loc, 1),
12136 High_Bound => Convert_To (RTE (RE_Storage_Offset),
12137 Task_Size)))))));
12138
12139 Append_To (Cdecls, Decl_Stack);
12140
12141 -- The appropriate alignment for the stack is ensured by the run-time
12142 -- code in charge of task creation.
12143
12144 end if;
12145
12146 -- Add components for entry families
12147
12148 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
12149
12150 -- Add the _Priority component if a Interrupt_Priority or Priority rep
12151 -- item is present.
12152
12153 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then
12154 Append_To (Cdecls,
12155 Make_Component_Declaration (Loc,
12156 Defining_Identifier =>
12157 Make_Defining_Identifier (Loc, Name_uPriority),
12158 Component_Definition =>
12159 Make_Component_Definition (Loc,
12160 Aliased_Present => False,
12161 Subtype_Indication =>
12162 New_Occurrence_Of (Standard_Integer, Loc))));
12163 end if;
12164
12165 -- Add the _Size component if a Storage_Size pragma is present
12166
12167 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then
12168 Append_To (Cdecls,
12169 Make_Component_Declaration (Loc,
12170 Defining_Identifier =>
12171 Make_Defining_Identifier (Loc, Name_uSize),
12172
12173 Component_Definition =>
12174 Make_Component_Definition (Loc,
12175 Aliased_Present => False,
12176 Subtype_Indication =>
12177 New_Occurrence_Of (RTE (RE_Size_Type), Loc)),
12178
12179 Expression =>
12180 Convert_To (RTE (RE_Size_Type),
12181 Relocate_Node (
12182 Expression (First (
12183 Pragma_Argument_Associations (
12184 Get_Rep_Pragma (TaskId, Name_Storage_Size))))))));
12185 end if;
12186
12187 -- Add the _Task_Info component if a Task_Info pragma is present
12188
12189 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then
12190 Append_To (Cdecls,
12191 Make_Component_Declaration (Loc,
12192 Defining_Identifier =>
12193 Make_Defining_Identifier (Loc, Name_uTask_Info),
12194
12195 Component_Definition =>
12196 Make_Component_Definition (Loc,
12197 Aliased_Present => False,
12198 Subtype_Indication =>
12199 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)),
12200
12201 Expression => New_Copy (
12202 Expression (First (
12203 Pragma_Argument_Associations (
12204 Get_Rep_Pragma
12205 (TaskId, Name_Task_Info, Check_Parents => False)))))));
12206 end if;
12207
12208 -- Add the _CPU component if a CPU rep item is present
12209
12210 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then
12211 Append_To (Cdecls,
12212 Make_Component_Declaration (Loc,
12213 Defining_Identifier =>
12214 Make_Defining_Identifier (Loc, Name_uCPU),
12215
12216 Component_Definition =>
12217 Make_Component_Definition (Loc,
12218 Aliased_Present => False,
12219 Subtype_Indication =>
12220 New_Occurrence_Of (RTE (RE_CPU_Range), Loc))));
12221 end if;
12222
12223 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is
12224 -- present. If we are using a restricted run time this component will
12225 -- not be added (deadlines are not allowed by the Ravenscar profile).
12226
12227 if not Restricted_Profile
12228 and then Present (Taskdef)
12229 and then Has_Relative_Deadline_Pragma (Taskdef)
12230 then
12231 Append_To (Cdecls,
12232 Make_Component_Declaration (Loc,
12233 Defining_Identifier =>
12234 Make_Defining_Identifier (Loc, Name_uRelative_Deadline),
12235
12236 Component_Definition =>
12237 Make_Component_Definition (Loc,
12238 Aliased_Present => False,
12239 Subtype_Indication =>
12240 New_Occurrence_Of (RTE (RE_Time_Span), Loc)),
12241
12242 Expression =>
12243 Convert_To (RTE (RE_Time_Span),
12244 Relocate_Node (
12245 Expression (First (
12246 Pragma_Argument_Associations (
12247 Get_Relative_Deadline_Pragma (Taskdef))))))));
12248 end if;
12249
12250 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
12251 -- item is present. If we are using a restricted run time this component
12252 -- will not be added (dispatching domains are not allowed by the
12253 -- Ravenscar profile).
12254
12255 if not Restricted_Profile
12256 and then
12257 Has_Rep_Item
12258 (TaskId, Name_Dispatching_Domain, Check_Parents => False)
12259 then
12260 Append_To (Cdecls,
12261 Make_Component_Declaration (Loc,
12262 Defining_Identifier =>
12263 Make_Defining_Identifier (Loc, Name_uDispatching_Domain),
12264
12265 Component_Definition =>
12266 Make_Component_Definition (Loc,
12267 Aliased_Present => False,
12268 Subtype_Indication =>
12269 New_Occurrence_Of
12270 (RTE (RE_Dispatching_Domain_Access), Loc))));
12271 end if;
12272
12273 Insert_After (Size_Decl, Rec_Decl);
12274
12275 -- Analyze the record declaration immediately after construction,
12276 -- because the initialization procedure is needed for single task
12277 -- declarations before the next entity is analyzed.
12278
12279 Analyze (Rec_Decl);
12280
12281 -- Create the declaration of the task body procedure
12282
12283 Proc_Spec := Build_Task_Proc_Specification (Tasktyp);
12284 Body_Decl :=
12285 Make_Subprogram_Declaration (Loc,
12286 Specification => Proc_Spec);
12287 Set_Is_Task_Body_Procedure (Body_Decl);
12288
12289 Insert_After (Rec_Decl, Body_Decl);
12290
12291 -- The subprogram does not comes from source, so we have to indicate the
12292 -- need for debugging information explicitly.
12293
12294 if Comes_From_Source (Original_Node (N)) then
12295 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec));
12296 end if;
12297
12298 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before
12299 -- the corresponding record has been frozen.
12300
12301 if Ada_Version >= Ada_2005 then
12302 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl);
12303 end if;
12304
12305 -- Ada 2005 (AI-345): We must defer freezing to allow further
12306 -- declaration of primitive subprograms covering task interfaces
12307
12308 if Ada_Version <= Ada_95 then
12309
12310 -- Now we can freeze the corresponding record. This needs manually
12311 -- freezing, since it is really part of the task type, and the task
12312 -- type is frozen at this stage. We of course need the initialization
12313 -- procedure for this corresponding record type and we won't get it
12314 -- in time if we don't freeze now.
12315
12316 declare
12317 L : constant List_Id := Freeze_Entity (Rec_Ent, N);
12318 begin
12319 if Is_Non_Empty_List (L) then
12320 Insert_List_After (Body_Decl, L);
12321 end if;
12322 end;
12323 end if;
12324
12325 -- Complete the expansion of access types to the current task type, if
12326 -- any were declared.
12327
12328 Expand_Previous_Access_Type (Tasktyp);
12329
12330 -- Create wrappers for entries that have contract cases, preconditions
12331 -- and postconditions.
12332
12333 declare
12334 Ent : Entity_Id;
12335
12336 begin
12337 Ent := First_Entity (Tasktyp);
12338 while Present (Ent) loop
12339 if Ekind_In (Ent, E_Entry, E_Entry_Family) then
12340 Build_Contract_Wrapper (Ent, N);
12341 end if;
12342
12343 Next_Entity (Ent);
12344 end loop;
12345 end;
12346 end Expand_N_Task_Type_Declaration;
12347
12348 -------------------------------
12349 -- Expand_N_Timed_Entry_Call --
12350 -------------------------------
12351
12352 -- A timed entry call in normal case is not implemented using ATC mechanism
12353 -- anymore for efficiency reason.
12354
12355 -- select
12356 -- T.E;
12357 -- S1;
12358 -- or
12359 -- delay D;
12360 -- S2;
12361 -- end select;
12362
12363 -- is expanded as follows:
12364
12365 -- 1) When T.E is a task entry_call;
12366
12367 -- declare
12368 -- B : Boolean;
12369 -- X : Task_Entry_Index := <entry index>;
12370 -- DX : Duration := To_Duration (D);
12371 -- M : Delay_Mode := <discriminant>;
12372 -- P : parms := (parm, parm, parm);
12373
12374 -- begin
12375 -- Timed_Protected_Entry_Call
12376 -- (<acceptor-task>, X, P'Address, DX, M, B);
12377 -- if B then
12378 -- S1;
12379 -- else
12380 -- S2;
12381 -- end if;
12382 -- end;
12383
12384 -- 2) When T.E is a protected entry_call;
12385
12386 -- declare
12387 -- B : Boolean;
12388 -- X : Protected_Entry_Index := <entry index>;
12389 -- DX : Duration := To_Duration (D);
12390 -- M : Delay_Mode := <discriminant>;
12391 -- P : parms := (parm, parm, parm);
12392
12393 -- begin
12394 -- Timed_Protected_Entry_Call
12395 -- (<object>'unchecked_access, X, P'Address, DX, M, B);
12396 -- if B then
12397 -- S1;
12398 -- else
12399 -- S2;
12400 -- end if;
12401 -- end;
12402
12403 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
12404 -- is no delay and the triggering statements are executed. We first
12405 -- determine the kind of the triggering call and then execute a
12406 -- synchronized operation or a direct call.
12407
12408 -- declare
12409 -- B : Boolean := False;
12410 -- C : Ada.Tags.Prim_Op_Kind;
12411 -- DX : Duration := To_Duration (D)
12412 -- K : Ada.Tags.Tagged_Kind :=
12413 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>));
12414 -- M : Integer :=...;
12415 -- P : Parameters := (Param1 .. ParamN);
12416 -- S : Integer;
12417
12418 -- begin
12419 -- if K = Ada.Tags.TK_Limited_Tagged
12420 -- or else K = Ada.Tags.TK_Tagged
12421 -- then
12422 -- <dispatching-call>;
12423 -- B := True;
12424
12425 -- else
12426 -- S :=
12427 -- Ada.Tags.Get_Offset_Index
12428 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>));
12429
12430 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B);
12431
12432 -- if C = POK_Protected_Entry
12433 -- or else C = POK_Task_Entry
12434 -- then
12435 -- Param1 := P.Param1;
12436 -- ...
12437 -- ParamN := P.ParamN;
12438 -- end if;
12439
12440 -- if B then
12441 -- if C = POK_Procedure
12442 -- or else C = POK_Protected_Procedure
12443 -- or else C = POK_Task_Procedure
12444 -- then
12445 -- <dispatching-call>;
12446 -- end if;
12447 -- end if;
12448 -- end if;
12449
12450 -- if B then
12451 -- <triggering-statements>
12452 -- else
12453 -- <timed-statements>
12454 -- end if;
12455 -- end;
12456
12457 -- The triggering statement and the sequence of timed statements have not
12458 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
12459 -- global references if within an instantiation.
12460
12461 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
12462 Loc : constant Source_Ptr := Sloc (N);
12463
12464 Actuals : List_Id;
12465 Blk_Typ : Entity_Id;
12466 Call : Node_Id;
12467 Call_Ent : Entity_Id;
12468 Conc_Typ_Stmts : List_Id;
12469 Concval : Node_Id;
12470 D_Alt : constant Node_Id := Delay_Alternative (N);
12471 D_Conv : Node_Id;
12472 D_Disc : Node_Id;
12473 D_Stat : Node_Id := Delay_Statement (D_Alt);
12474 D_Stats : List_Id;
12475 D_Type : Entity_Id;
12476 Decls : List_Id;
12477 Dummy : Node_Id;
12478 E_Alt : constant Node_Id := Entry_Call_Alternative (N);
12479 E_Call : Node_Id := Entry_Call_Statement (E_Alt);
12480 E_Stats : List_Id;
12481 Ename : Node_Id;
12482 Formals : List_Id;
12483 Index : Node_Id;
12484 Is_Disp_Select : Boolean;
12485 Lim_Typ_Stmts : List_Id;
12486 N_Stats : List_Id;
12487 Obj : Entity_Id;
12488 Param : Node_Id;
12489 Params : List_Id;
12490 Stmt : Node_Id;
12491 Stmts : List_Id;
12492 Unpack : List_Id;
12493
12494 B : Entity_Id; -- Call status flag
12495 C : Entity_Id; -- Call kind
12496 D : Entity_Id; -- Delay
12497 K : Entity_Id; -- Tagged kind
12498 M : Entity_Id; -- Delay mode
12499 P : Entity_Id; -- Parameter block
12500 S : Entity_Id; -- Primitive operation slot
12501
12502 -- Start of processing for Expand_N_Timed_Entry_Call
12503
12504 begin
12505 -- Under the Ravenscar profile, timed entry calls are excluded. An error
12506 -- was already reported on spec, so do not attempt to expand the call.
12507
12508 if Restriction_Active (No_Select_Statements) then
12509 return;
12510 end if;
12511
12512 Process_Statements_For_Controlled_Objects (E_Alt);
12513 Process_Statements_For_Controlled_Objects (D_Alt);
12514
12515 Ensure_Statement_Present (Sloc (D_Stat), D_Alt);
12516
12517 -- Retrieve E_Stats and D_Stats now because the finalization machinery
12518 -- may wrap them in blocks.
12519
12520 E_Stats := Statements (E_Alt);
12521 D_Stats := Statements (D_Alt);
12522
12523 -- The arguments in the call may require dynamic allocation, and the
12524 -- call statement may have been transformed into a block. The block
12525 -- may contain additional declarations for internal entities, and the
12526 -- original call is found by sequential search.
12527
12528 if Nkind (E_Call) = N_Block_Statement then
12529 E_Call := First (Statements (Handled_Statement_Sequence (E_Call)));
12530 while not Nkind_In (E_Call, N_Procedure_Call_Statement,
12531 N_Entry_Call_Statement)
12532 loop
12533 Next (E_Call);
12534 end loop;
12535 end if;
12536
12537 Is_Disp_Select :=
12538 Ada_Version >= Ada_2005
12539 and then Nkind (E_Call) = N_Procedure_Call_Statement;
12540
12541 if Is_Disp_Select then
12542 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
12543 Decls := New_List;
12544
12545 Stmts := New_List;
12546
12547 -- Generate:
12548 -- B : Boolean := False;
12549
12550 B := Build_B (Loc, Decls);
12551
12552 -- Generate:
12553 -- C : Ada.Tags.Prim_Op_Kind;
12554
12555 C := Build_C (Loc, Decls);
12556
12557 -- Because the analysis of all statements was disabled, manually
12558 -- analyze the delay statement.
12559
12560 Analyze (D_Stat);
12561 D_Stat := Original_Node (D_Stat);
12562
12563 else
12564 -- Build an entry call using Simple_Entry_Call
12565
12566 Extract_Entry (E_Call, Concval, Ename, Index);
12567 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index);
12568
12569 Decls := Declarations (E_Call);
12570 Stmts := Statements (Handled_Statement_Sequence (E_Call));
12571
12572 if No (Decls) then
12573 Decls := New_List;
12574 end if;
12575
12576 -- Generate:
12577 -- B : Boolean;
12578
12579 B := Make_Defining_Identifier (Loc, Name_uB);
12580
12581 Prepend_To (Decls,
12582 Make_Object_Declaration (Loc,
12583 Defining_Identifier => B,
12584 Object_Definition =>
12585 New_Occurrence_Of (Standard_Boolean, Loc)));
12586 end if;
12587
12588 -- Duration and mode processing
12589
12590 D_Type := Base_Type (Etype (Expression (D_Stat)));
12591
12592 -- Use the type of the delay expression (Calendar or Real_Time) to
12593 -- generate the appropriate conversion.
12594
12595 if Nkind (D_Stat) = N_Delay_Relative_Statement then
12596 D_Disc := Make_Integer_Literal (Loc, 0);
12597 D_Conv := Relocate_Node (Expression (D_Stat));
12598
12599 elsif Is_RTE (D_Type, RO_CA_Time) then
12600 D_Disc := Make_Integer_Literal (Loc, 1);
12601 D_Conv :=
12602 Make_Function_Call (Loc,
12603 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc),
12604 Parameter_Associations =>
12605 New_List (New_Copy (Expression (D_Stat))));
12606
12607 else pragma Assert (Is_RTE (D_Type, RO_RT_Time));
12608 D_Disc := Make_Integer_Literal (Loc, 2);
12609 D_Conv :=
12610 Make_Function_Call (Loc,
12611 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
12612 Parameter_Associations =>
12613 New_List (New_Copy (Expression (D_Stat))));
12614 end if;
12615
12616 D := Make_Temporary (Loc, 'D');
12617
12618 -- Generate:
12619 -- D : Duration;
12620
12621 Append_To (Decls,
12622 Make_Object_Declaration (Loc,
12623 Defining_Identifier => D,
12624 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc)));
12625
12626 M := Make_Temporary (Loc, 'M');
12627
12628 -- Generate:
12629 -- M : Integer := (0 | 1 | 2);
12630
12631 Append_To (Decls,
12632 Make_Object_Declaration (Loc,
12633 Defining_Identifier => M,
12634 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
12635 Expression => D_Disc));
12636
12637 -- Do the assignment at this stage only because the evaluation of the
12638 -- expression must not occur before (see ACVC C97302A).
12639
12640 Append_To (Stmts,
12641 Make_Assignment_Statement (Loc,
12642 Name => New_Occurrence_Of (D, Loc),
12643 Expression => D_Conv));
12644
12645 -- Parameter block processing
12646
12647 -- Manually create the parameter block for dispatching calls. In the
12648 -- case of entries, the block has already been created during the call
12649 -- to Build_Simple_Entry_Call.
12650
12651 if Is_Disp_Select then
12652
12653 -- Tagged kind processing, generate:
12654 -- K : Ada.Tags.Tagged_Kind :=
12655 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>));
12656
12657 K := Build_K (Loc, Decls, Obj);
12658
12659 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls);
12660 P :=
12661 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts);
12662
12663 -- Dispatch table slot processing, generate:
12664 -- S : Integer;
12665
12666 S := Build_S (Loc, Decls);
12667
12668 -- Generate:
12669 -- S := Ada.Tags.Get_Offset_Index
12670 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent));
12671
12672 Conc_Typ_Stmts :=
12673 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent));
12674
12675 -- Generate:
12676 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B);
12677
12678 -- where Obj is the controlling formal parameter, S is the dispatch
12679 -- table slot number of the dispatching operation, P is the wrapped
12680 -- parameter block, D is the duration, M is the duration mode, C is
12681 -- the call kind and B is the call status.
12682
12683 Params := New_List;
12684
12685 Append_To (Params, New_Copy_Tree (Obj));
12686 Append_To (Params, New_Occurrence_Of (S, Loc));
12687 Append_To (Params,
12688 Make_Attribute_Reference (Loc,
12689 Prefix => New_Occurrence_Of (P, Loc),
12690 Attribute_Name => Name_Address));
12691 Append_To (Params, New_Occurrence_Of (D, Loc));
12692 Append_To (Params, New_Occurrence_Of (M, Loc));
12693 Append_To (Params, New_Occurrence_Of (C, Loc));
12694 Append_To (Params, New_Occurrence_Of (B, Loc));
12695
12696 Append_To (Conc_Typ_Stmts,
12697 Make_Procedure_Call_Statement (Loc,
12698 Name =>
12699 New_Occurrence_Of
12700 (Find_Prim_Op
12701 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc),
12702 Parameter_Associations => Params));
12703
12704 -- Generate:
12705 -- if C = POK_Protected_Entry
12706 -- or else C = POK_Task_Entry
12707 -- then
12708 -- Param1 := P.Param1;
12709 -- ...
12710 -- ParamN := P.ParamN;
12711 -- end if;
12712
12713 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals);
12714
12715 -- Generate the if statement only when the packed parameters need
12716 -- explicit assignments to their corresponding actuals.
12717
12718 if Present (Unpack) then
12719 Append_To (Conc_Typ_Stmts,
12720 Make_Implicit_If_Statement (N,
12721
12722 Condition =>
12723 Make_Or_Else (Loc,
12724 Left_Opnd =>
12725 Make_Op_Eq (Loc,
12726 Left_Opnd => New_Occurrence_Of (C, Loc),
12727 Right_Opnd =>
12728 New_Occurrence_Of
12729 (RTE (RE_POK_Protected_Entry), Loc)),
12730
12731 Right_Opnd =>
12732 Make_Op_Eq (Loc,
12733 Left_Opnd => New_Occurrence_Of (C, Loc),
12734 Right_Opnd =>
12735 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))),
12736
12737 Then_Statements => Unpack));
12738 end if;
12739
12740 -- Generate:
12741
12742 -- if B then
12743 -- if C = POK_Procedure
12744 -- or else C = POK_Protected_Procedure
12745 -- or else C = POK_Task_Procedure
12746 -- then
12747 -- <dispatching-call>
12748 -- end if;
12749 -- end if;
12750
12751 N_Stats := New_List (
12752 Make_Implicit_If_Statement (N,
12753 Condition =>
12754 Make_Or_Else (Loc,
12755 Left_Opnd =>
12756 Make_Op_Eq (Loc,
12757 Left_Opnd => New_Occurrence_Of (C, Loc),
12758 Right_Opnd =>
12759 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)),
12760
12761 Right_Opnd =>
12762 Make_Or_Else (Loc,
12763 Left_Opnd =>
12764 Make_Op_Eq (Loc,
12765 Left_Opnd => New_Occurrence_Of (C, Loc),
12766 Right_Opnd =>
12767 New_Occurrence_Of (RTE (
12768 RE_POK_Protected_Procedure), Loc)),
12769 Right_Opnd =>
12770 Make_Op_Eq (Loc,
12771 Left_Opnd => New_Occurrence_Of (C, Loc),
12772 Right_Opnd =>
12773 New_Occurrence_Of
12774 (RTE (RE_POK_Task_Procedure), Loc)))),
12775
12776 Then_Statements => New_List (E_Call)));
12777
12778 Append_To (Conc_Typ_Stmts,
12779 Make_Implicit_If_Statement (N,
12780 Condition => New_Occurrence_Of (B, Loc),
12781 Then_Statements => N_Stats));
12782
12783 -- Generate:
12784 -- <dispatching-call>;
12785 -- B := True;
12786
12787 Lim_Typ_Stmts :=
12788 New_List (New_Copy_Tree (E_Call),
12789 Make_Assignment_Statement (Loc,
12790 Name => New_Occurrence_Of (B, Loc),
12791 Expression => New_Occurrence_Of (Standard_True, Loc)));
12792
12793 -- Generate:
12794 -- if K = Ada.Tags.TK_Limited_Tagged
12795 -- or else K = Ada.Tags.TK_Tagged
12796 -- then
12797 -- Lim_Typ_Stmts
12798 -- else
12799 -- Conc_Typ_Stmts
12800 -- end if;
12801
12802 Append_To (Stmts,
12803 Make_Implicit_If_Statement (N,
12804 Condition => Build_Dispatching_Tag_Check (K, N),
12805 Then_Statements => Lim_Typ_Stmts,
12806 Else_Statements => Conc_Typ_Stmts));
12807
12808 -- Generate:
12809
12810 -- if B then
12811 -- <triggering-statements>
12812 -- else
12813 -- <timed-statements>
12814 -- end if;
12815
12816 Append_To (Stmts,
12817 Make_Implicit_If_Statement (N,
12818 Condition => New_Occurrence_Of (B, Loc),
12819 Then_Statements => E_Stats,
12820 Else_Statements => D_Stats));
12821
12822 else
12823 -- Simple case of a nondispatching trigger. Skip assignments to
12824 -- temporaries created for in-out parameters.
12825
12826 -- This makes unwarranted assumptions about the shape of the expanded
12827 -- tree for the call, and should be cleaned up ???
12828
12829 Stmt := First (Stmts);
12830 while Nkind (Stmt) /= N_Procedure_Call_Statement loop
12831 Next (Stmt);
12832 end loop;
12833
12834 -- Do the assignment at this stage only because the evaluation
12835 -- of the expression must not occur before (see ACVC C97302A).
12836
12837 Insert_Before (Stmt,
12838 Make_Assignment_Statement (Loc,
12839 Name => New_Occurrence_Of (D, Loc),
12840 Expression => D_Conv));
12841
12842 Call := Stmt;
12843 Params := Parameter_Associations (Call);
12844
12845 -- For a protected type, we build a Timed_Protected_Entry_Call
12846
12847 if Is_Protected_Type (Etype (Concval)) then
12848
12849 -- Create a new call statement
12850
12851 Param := First (Params);
12852 while Present (Param)
12853 and then not Is_RTE (Etype (Param), RE_Call_Modes)
12854 loop
12855 Next (Param);
12856 end loop;
12857
12858 Dummy := Remove_Next (Next (Param));
12859
12860 -- Remove garbage is following the Cancel_Param if present
12861
12862 Dummy := Next (Param);
12863
12864 -- Remove the mode of the Protected_Entry_Call call, then remove
12865 -- the Communication_Block of the Protected_Entry_Call call, and
12866 -- finally add Duration and a Delay_Mode parameter
12867
12868 pragma Assert (Present (Param));
12869 Rewrite (Param, New_Occurrence_Of (D, Loc));
12870
12871 Rewrite (Dummy, New_Occurrence_Of (M, Loc));
12872
12873 -- Add a Boolean flag for successful entry call
12874
12875 Append_To (Params, New_Occurrence_Of (B, Loc));
12876
12877 case Corresponding_Runtime_Package (Etype (Concval)) is
12878 when System_Tasking_Protected_Objects_Entries =>
12879 Rewrite (Call,
12880 Make_Procedure_Call_Statement (Loc,
12881 Name =>
12882 New_Occurrence_Of
12883 (RTE (RE_Timed_Protected_Entry_Call), Loc),
12884 Parameter_Associations => Params));
12885
12886 when others =>
12887 raise Program_Error;
12888 end case;
12889
12890 -- For the task case, build a Timed_Task_Entry_Call
12891
12892 else
12893 -- Create a new call statement
12894
12895 Append_To (Params, New_Occurrence_Of (D, Loc));
12896 Append_To (Params, New_Occurrence_Of (M, Loc));
12897 Append_To (Params, New_Occurrence_Of (B, Loc));
12898
12899 Rewrite (Call,
12900 Make_Procedure_Call_Statement (Loc,
12901 Name =>
12902 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc),
12903 Parameter_Associations => Params));
12904 end if;
12905
12906 Append_To (Stmts,
12907 Make_Implicit_If_Statement (N,
12908 Condition => New_Occurrence_Of (B, Loc),
12909 Then_Statements => E_Stats,
12910 Else_Statements => D_Stats));
12911 end if;
12912
12913 Rewrite (N,
12914 Make_Block_Statement (Loc,
12915 Declarations => Decls,
12916 Handled_Statement_Sequence =>
12917 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
12918
12919 Analyze (N);
12920 end Expand_N_Timed_Entry_Call;
12921
12922 ----------------------------------------
12923 -- Expand_Protected_Body_Declarations --
12924 ----------------------------------------
12925
12926 procedure Expand_Protected_Body_Declarations
12927 (N : Node_Id;
12928 Spec_Id : Entity_Id)
12929 is
12930 begin
12931 if No_Run_Time_Mode then
12932 Error_Msg_CRT ("protected body", N);
12933 return;
12934
12935 elsif Expander_Active then
12936
12937 -- Associate discriminals with the first subprogram or entry body to
12938 -- be expanded.
12939
12940 if Present (First_Protected_Operation (Declarations (N))) then
12941 Set_Discriminals (Parent (Spec_Id));
12942 end if;
12943 end if;
12944 end Expand_Protected_Body_Declarations;
12945
12946 -------------------------
12947 -- External_Subprogram --
12948 -------------------------
12949
12950 function External_Subprogram (E : Entity_Id) return Entity_Id is
12951 Subp : constant Entity_Id := Protected_Body_Subprogram (E);
12952
12953 begin
12954 -- The internal and external subprograms follow each other on the entity
12955 -- chain. Note that previously private operations had no separate
12956 -- external subprogram. We now create one in all cases, because a
12957 -- private operation may actually appear in an external call, through
12958 -- a 'Access reference used for a callback.
12959
12960 -- If the operation is a function that returns an anonymous access type,
12961 -- the corresponding itype appears before the operation, and must be
12962 -- skipped.
12963
12964 -- This mechanism is fragile, there should be a real link between the
12965 -- two versions of the operation, but there is no place to put it ???
12966
12967 if Is_Access_Type (Next_Entity (Subp)) then
12968 return Next_Entity (Next_Entity (Subp));
12969 else
12970 return Next_Entity (Subp);
12971 end if;
12972 end External_Subprogram;
12973
12974 ------------------------------
12975 -- Extract_Dispatching_Call --
12976 ------------------------------
12977
12978 procedure Extract_Dispatching_Call
12979 (N : Node_Id;
12980 Call_Ent : out Entity_Id;
12981 Object : out Entity_Id;
12982 Actuals : out List_Id;
12983 Formals : out List_Id)
12984 is
12985 Call_Nam : Node_Id;
12986
12987 begin
12988 pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
12989
12990 if Present (Original_Node (N)) then
12991 Call_Nam := Name (Original_Node (N));
12992 else
12993 Call_Nam := Name (N);
12994 end if;
12995
12996 -- Retrieve the name of the dispatching procedure. It contains the
12997 -- dispatch table slot number.
12998
12999 loop
13000 case Nkind (Call_Nam) is
13001 when N_Identifier =>
13002 exit;
13003
13004 when N_Selected_Component =>
13005 Call_Nam := Selector_Name (Call_Nam);
13006
13007 when others =>
13008 raise Program_Error;
13009
13010 end case;
13011 end loop;
13012
13013 Actuals := Parameter_Associations (N);
13014 Call_Ent := Entity (Call_Nam);
13015 Formals := Parameter_Specifications (Parent (Call_Ent));
13016 Object := First (Actuals);
13017
13018 if Present (Original_Node (Object)) then
13019 Object := Original_Node (Object);
13020 end if;
13021
13022 -- If the type of the dispatching object is an access type then return
13023 -- an explicit dereference.
13024
13025 if Is_Access_Type (Etype (Object)) then
13026 Object := Make_Explicit_Dereference (Sloc (N), Object);
13027 Analyze (Object);
13028 end if;
13029 end Extract_Dispatching_Call;
13030
13031 -------------------
13032 -- Extract_Entry --
13033 -------------------
13034
13035 procedure Extract_Entry
13036 (N : Node_Id;
13037 Concval : out Node_Id;
13038 Ename : out Node_Id;
13039 Index : out Node_Id)
13040 is
13041 Nam : constant Node_Id := Name (N);
13042
13043 begin
13044 -- For a simple entry, the name is a selected component, with the
13045 -- prefix being the task value, and the selector being the entry.
13046
13047 if Nkind (Nam) = N_Selected_Component then
13048 Concval := Prefix (Nam);
13049 Ename := Selector_Name (Nam);
13050 Index := Empty;
13051
13052 -- For a member of an entry family, the name is an indexed component
13053 -- where the prefix is a selected component, whose prefix in turn is
13054 -- the task value, and whose selector is the entry family. The single
13055 -- expression in the expressions list of the indexed component is the
13056 -- subscript for the family.
13057
13058 else pragma Assert (Nkind (Nam) = N_Indexed_Component);
13059 Concval := Prefix (Prefix (Nam));
13060 Ename := Selector_Name (Prefix (Nam));
13061 Index := First (Expressions (Nam));
13062 end if;
13063
13064 -- Through indirection, the type may actually be a limited view of a
13065 -- concurrent type. When compiling a call, the non-limited view of the
13066 -- type is visible.
13067
13068 if From_Limited_With (Etype (Concval)) then
13069 Set_Etype (Concval, Non_Limited_View (Etype (Concval)));
13070 end if;
13071 end Extract_Entry;
13072
13073 -------------------
13074 -- Family_Offset --
13075 -------------------
13076
13077 function Family_Offset
13078 (Loc : Source_Ptr;
13079 Hi : Node_Id;
13080 Lo : Node_Id;
13081 Ttyp : Entity_Id;
13082 Cap : Boolean) return Node_Id
13083 is
13084 Ityp : Entity_Id;
13085 Real_Hi : Node_Id;
13086 Real_Lo : Node_Id;
13087
13088 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
13089 -- If one of the bounds is a reference to a discriminant, replace with
13090 -- corresponding discriminal of type. Within the body of a task retrieve
13091 -- the renamed discriminant by simple visibility, using its generated
13092 -- name. Within a protected object, find the original discriminant and
13093 -- replace it with the discriminal of the current protected operation.
13094
13095 ------------------------------
13096 -- Convert_Discriminant_Ref --
13097 ------------------------------
13098
13099 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
13100 Loc : constant Source_Ptr := Sloc (Bound);
13101 B : Node_Id;
13102 D : Entity_Id;
13103
13104 begin
13105 if Is_Entity_Name (Bound)
13106 and then Ekind (Entity (Bound)) = E_Discriminant
13107 then
13108 if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then
13109 B := Make_Identifier (Loc, Chars (Entity (Bound)));
13110 Find_Direct_Name (B);
13111
13112 elsif Is_Protected_Type (Ttyp) then
13113 D := First_Discriminant (Ttyp);
13114 while Chars (D) /= Chars (Entity (Bound)) loop
13115 Next_Discriminant (D);
13116 end loop;
13117
13118 B := New_Occurrence_Of (Discriminal (D), Loc);
13119
13120 else
13121 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
13122 end if;
13123
13124 elsif Nkind (Bound) = N_Attribute_Reference then
13125 return Bound;
13126
13127 else
13128 B := New_Copy_Tree (Bound);
13129 end if;
13130
13131 return
13132 Make_Attribute_Reference (Loc,
13133 Attribute_Name => Name_Pos,
13134 Prefix => New_Occurrence_Of (Etype (Bound), Loc),
13135 Expressions => New_List (B));
13136 end Convert_Discriminant_Ref;
13137
13138 -- Start of processing for Family_Offset
13139
13140 begin
13141 Real_Hi := Convert_Discriminant_Ref (Hi);
13142 Real_Lo := Convert_Discriminant_Ref (Lo);
13143
13144 if Cap then
13145 if Is_Task_Type (Ttyp) then
13146 Ityp := RTE (RE_Task_Entry_Index);
13147 else
13148 Ityp := RTE (RE_Protected_Entry_Index);
13149 end if;
13150
13151 Real_Hi :=
13152 Make_Attribute_Reference (Loc,
13153 Prefix => New_Occurrence_Of (Ityp, Loc),
13154 Attribute_Name => Name_Min,
13155 Expressions => New_List (
13156 Real_Hi,
13157 Make_Integer_Literal (Loc, Entry_Family_Bound - 1)));
13158
13159 Real_Lo :=
13160 Make_Attribute_Reference (Loc,
13161 Prefix => New_Occurrence_Of (Ityp, Loc),
13162 Attribute_Name => Name_Max,
13163 Expressions => New_List (
13164 Real_Lo,
13165 Make_Integer_Literal (Loc, -Entry_Family_Bound)));
13166 end if;
13167
13168 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo);
13169 end Family_Offset;
13170
13171 -----------------
13172 -- Family_Size --
13173 -----------------
13174
13175 function Family_Size
13176 (Loc : Source_Ptr;
13177 Hi : Node_Id;
13178 Lo : Node_Id;
13179 Ttyp : Entity_Id;
13180 Cap : Boolean) return Node_Id
13181 is
13182 Ityp : Entity_Id;
13183
13184 begin
13185 if Is_Task_Type (Ttyp) then
13186 Ityp := RTE (RE_Task_Entry_Index);
13187 else
13188 Ityp := RTE (RE_Protected_Entry_Index);
13189 end if;
13190
13191 return
13192 Make_Attribute_Reference (Loc,
13193 Prefix => New_Occurrence_Of (Ityp, Loc),
13194 Attribute_Name => Name_Max,
13195 Expressions => New_List (
13196 Make_Op_Add (Loc,
13197 Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap),
13198 Right_Opnd => Make_Integer_Literal (Loc, 1)),
13199 Make_Integer_Literal (Loc, 0)));
13200 end Family_Size;
13201
13202 ----------------------------
13203 -- Find_Enclosing_Context --
13204 ----------------------------
13205
13206 procedure Find_Enclosing_Context
13207 (N : Node_Id;
13208 Context : out Node_Id;
13209 Context_Id : out Entity_Id;
13210 Context_Decls : out List_Id)
13211 is
13212 begin
13213 -- Traverse the parent chain looking for an enclosing body, block,
13214 -- package or return statement.
13215
13216 Context := Parent (N);
13217 while not Nkind_In (Context, N_Block_Statement,
13218 N_Entry_Body,
13219 N_Extended_Return_Statement,
13220 N_Package_Body,
13221 N_Package_Declaration,
13222 N_Subprogram_Body,
13223 N_Task_Body)
13224 loop
13225 Context := Parent (Context);
13226 end loop;
13227
13228 -- Extract the constituents of the context
13229
13230 if Nkind (Context) = N_Extended_Return_Statement then
13231 Context_Decls := Return_Object_Declarations (Context);
13232 Context_Id := Return_Statement_Entity (Context);
13233
13234 -- Package declarations and bodies use a common library-level activation
13235 -- chain or task master, therefore return the package declaration as the
13236 -- proper carrier for the appropriate flag.
13237
13238 elsif Nkind (Context) = N_Package_Body then
13239 Context_Decls := Declarations (Context);
13240 Context_Id := Corresponding_Spec (Context);
13241 Context := Parent (Context_Id);
13242
13243 if Nkind (Context) = N_Defining_Program_Unit_Name then
13244 Context := Parent (Parent (Context));
13245 else
13246 Context := Parent (Context);
13247 end if;
13248
13249 elsif Nkind (Context) = N_Package_Declaration then
13250 Context_Decls := Visible_Declarations (Specification (Context));
13251 Context_Id := Defining_Unit_Name (Specification (Context));
13252
13253 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then
13254 Context_Id := Defining_Identifier (Context_Id);
13255 end if;
13256
13257 else
13258 Context_Decls := Declarations (Context);
13259
13260 if Nkind (Context) = N_Block_Statement then
13261 Context_Id := Entity (Identifier (Context));
13262
13263 elsif Nkind (Context) = N_Entry_Body then
13264 Context_Id := Defining_Identifier (Context);
13265
13266 elsif Nkind (Context) = N_Subprogram_Body then
13267 if Present (Corresponding_Spec (Context)) then
13268 Context_Id := Corresponding_Spec (Context);
13269 else
13270 Context_Id := Defining_Unit_Name (Specification (Context));
13271
13272 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then
13273 Context_Id := Defining_Identifier (Context_Id);
13274 end if;
13275 end if;
13276
13277 elsif Nkind (Context) = N_Task_Body then
13278 Context_Id := Corresponding_Spec (Context);
13279
13280 else
13281 raise Program_Error;
13282 end if;
13283 end if;
13284
13285 pragma Assert (Present (Context));
13286 pragma Assert (Present (Context_Id));
13287 pragma Assert (Present (Context_Decls));
13288 end Find_Enclosing_Context;
13289
13290 -----------------------
13291 -- Find_Master_Scope --
13292 -----------------------
13293
13294 function Find_Master_Scope (E : Entity_Id) return Entity_Id is
13295 S : Entity_Id;
13296
13297 begin
13298 -- In Ada 2005, the master is the innermost enclosing scope that is not
13299 -- transient. If the enclosing block is the rewriting of a call or the
13300 -- scope is an extended return statement this is valid master. The
13301 -- master in an extended return is only used within the return, and is
13302 -- subsequently overwritten in Move_Activation_Chain, but it must exist
13303 -- now before that overwriting occurs.
13304
13305 S := Scope (E);
13306
13307 if Ada_Version >= Ada_2005 then
13308 while Is_Internal (S) loop
13309 if Nkind (Parent (S)) = N_Block_Statement
13310 and then
13311 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement
13312 then
13313 exit;
13314
13315 elsif Ekind (S) = E_Return_Statement then
13316 exit;
13317
13318 else
13319 S := Scope (S);
13320 end if;
13321 end loop;
13322 end if;
13323
13324 return S;
13325 end Find_Master_Scope;
13326
13327 -------------------------------
13328 -- First_Protected_Operation --
13329 -------------------------------
13330
13331 function First_Protected_Operation (D : List_Id) return Node_Id is
13332 First_Op : Node_Id;
13333
13334 begin
13335 First_Op := First (D);
13336 while Present (First_Op)
13337 and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body)
13338 loop
13339 Next (First_Op);
13340 end loop;
13341
13342 return First_Op;
13343 end First_Protected_Operation;
13344
13345 ---------------------------------------
13346 -- Install_Private_Data_Declarations --
13347 ---------------------------------------
13348
13349 procedure Install_Private_Data_Declarations
13350 (Loc : Source_Ptr;
13351 Spec_Id : Entity_Id;
13352 Conc_Typ : Entity_Id;
13353 Body_Nod : Node_Id;
13354 Decls : List_Id;
13355 Barrier : Boolean := False;
13356 Family : Boolean := False)
13357 is
13358 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ);
13359 Decl : Node_Id;
13360 Def : Node_Id;
13361 Insert_Node : Node_Id := Empty;
13362 Obj_Ent : Entity_Id;
13363
13364 procedure Add (Decl : Node_Id);
13365 -- Add a single declaration after Insert_Node. If this is the first
13366 -- addition, Decl is added to the front of Decls and it becomes the
13367 -- insertion node.
13368
13369 function Replace_Bound (Bound : Node_Id) return Node_Id;
13370 -- The bounds of an entry index may depend on discriminants, create a
13371 -- reference to the corresponding prival. Otherwise return a duplicate
13372 -- of the original bound.
13373
13374 ---------
13375 -- Add --
13376 ---------
13377
13378 procedure Add (Decl : Node_Id) is
13379 begin
13380 if No (Insert_Node) then
13381 Prepend_To (Decls, Decl);
13382 else
13383 Insert_After (Insert_Node, Decl);
13384 end if;
13385
13386 Insert_Node := Decl;
13387 end Add;
13388
13389 --------------------------
13390 -- Replace_Discriminant --
13391 --------------------------
13392
13393 function Replace_Bound (Bound : Node_Id) return Node_Id is
13394 begin
13395 if Nkind (Bound) = N_Identifier
13396 and then Is_Discriminal (Entity (Bound))
13397 then
13398 return Make_Identifier (Loc, Chars (Entity (Bound)));
13399 else
13400 return Duplicate_Subexpr (Bound);
13401 end if;
13402 end Replace_Bound;
13403
13404 -- Start of processing for Install_Private_Data_Declarations
13405
13406 begin
13407 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote
13408 -- formal parameter _O, _object or _task depending on the context.
13409
13410 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ);
13411
13412 -- Special processing of _O for barrier functions, protected entries
13413 -- and families.
13414
13415 if Barrier
13416 or else
13417 (Is_Protected
13418 and then
13419 (Ekind (Spec_Id) = E_Entry
13420 or else Ekind (Spec_Id) = E_Entry_Family))
13421 then
13422 declare
13423 Conc_Rec : constant Entity_Id :=
13424 Corresponding_Record_Type (Conc_Typ);
13425 Typ_Id : constant Entity_Id :=
13426 Make_Defining_Identifier (Loc,
13427 New_External_Name (Chars (Conc_Rec), 'P'));
13428 begin
13429 -- Generate:
13430 -- type prot_typVP is access prot_typV;
13431
13432 Decl :=
13433 Make_Full_Type_Declaration (Loc,
13434 Defining_Identifier => Typ_Id,
13435 Type_Definition =>
13436 Make_Access_To_Object_Definition (Loc,
13437 Subtype_Indication =>
13438 New_Occurrence_Of (Conc_Rec, Loc)));
13439 Add (Decl);
13440
13441 -- Generate:
13442 -- _object : prot_typVP := prot_typV (_O);
13443
13444 Decl :=
13445 Make_Object_Declaration (Loc,
13446 Defining_Identifier =>
13447 Make_Defining_Identifier (Loc, Name_uObject),
13448 Object_Definition => New_Occurrence_Of (Typ_Id, Loc),
13449 Expression =>
13450 Unchecked_Convert_To (Typ_Id,
13451 New_Occurrence_Of (Obj_Ent, Loc)));
13452 Add (Decl);
13453
13454 -- Set the reference to the concurrent object
13455
13456 Obj_Ent := Defining_Identifier (Decl);
13457 end;
13458 end if;
13459
13460 -- Step 2: Create the Protection object and build its declaration for
13461 -- any protected entry (family) of subprogram. Note for the lock-free
13462 -- implementation, the Protection object is not needed anymore.
13463
13464 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then
13465 declare
13466 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R');
13467 Prot_Typ : RE_Id;
13468
13469 begin
13470 Set_Protection_Object (Spec_Id, Prot_Ent);
13471
13472 -- Determine the proper protection type
13473
13474 if Has_Attach_Handler (Conc_Typ)
13475 and then not Restricted_Profile
13476 then
13477 Prot_Typ := RE_Static_Interrupt_Protection;
13478
13479 elsif Has_Interrupt_Handler (Conc_Typ)
13480 and then not Restriction_Active (No_Dynamic_Attachment)
13481 then
13482 Prot_Typ := RE_Dynamic_Interrupt_Protection;
13483
13484 else
13485 case Corresponding_Runtime_Package (Conc_Typ) is
13486 when System_Tasking_Protected_Objects_Entries =>
13487 Prot_Typ := RE_Protection_Entries;
13488
13489 when System_Tasking_Protected_Objects_Single_Entry =>
13490 Prot_Typ := RE_Protection_Entry;
13491
13492 when System_Tasking_Protected_Objects =>
13493 Prot_Typ := RE_Protection;
13494
13495 when others =>
13496 raise Program_Error;
13497 end case;
13498 end if;
13499
13500 -- Generate:
13501 -- conc_typR : protection_typ renames _object._object;
13502
13503 Decl :=
13504 Make_Object_Renaming_Declaration (Loc,
13505 Defining_Identifier => Prot_Ent,
13506 Subtype_Mark =>
13507 New_Occurrence_Of (RTE (Prot_Typ), Loc),
13508 Name =>
13509 Make_Selected_Component (Loc,
13510 Prefix => New_Occurrence_Of (Obj_Ent, Loc),
13511 Selector_Name => Make_Identifier (Loc, Name_uObject)));
13512 Add (Decl);
13513 end;
13514 end if;
13515
13516 -- Step 3: Add discriminant renamings (if any)
13517
13518 if Has_Discriminants (Conc_Typ) then
13519 declare
13520 D : Entity_Id;
13521
13522 begin
13523 D := First_Discriminant (Conc_Typ);
13524 while Present (D) loop
13525
13526 -- Adjust the source location
13527
13528 Set_Sloc (Discriminal (D), Loc);
13529
13530 -- Generate:
13531 -- discr_name : discr_typ renames _object.discr_name;
13532 -- or
13533 -- discr_name : discr_typ renames _task.discr_name;
13534
13535 Decl :=
13536 Make_Object_Renaming_Declaration (Loc,
13537 Defining_Identifier => Discriminal (D),
13538 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc),
13539 Name =>
13540 Make_Selected_Component (Loc,
13541 Prefix => New_Occurrence_Of (Obj_Ent, Loc),
13542 Selector_Name => Make_Identifier (Loc, Chars (D))));
13543 Add (Decl);
13544
13545 Next_Discriminant (D);
13546 end loop;
13547 end;
13548 end if;
13549
13550 -- Step 4: Add private component renamings (if any)
13551
13552 if Is_Protected then
13553 Def := Protected_Definition (Parent (Conc_Typ));
13554
13555 if Present (Private_Declarations (Def)) then
13556 declare
13557 Comp : Node_Id;
13558 Comp_Id : Entity_Id;
13559 Decl_Id : Entity_Id;
13560
13561 begin
13562 Comp := First (Private_Declarations (Def));
13563 while Present (Comp) loop
13564 if Nkind (Comp) = N_Component_Declaration then
13565 Comp_Id := Defining_Identifier (Comp);
13566 Decl_Id :=
13567 Make_Defining_Identifier (Loc, Chars (Comp_Id));
13568
13569 -- Minimal decoration
13570
13571 if Ekind (Spec_Id) = E_Function then
13572 Set_Ekind (Decl_Id, E_Constant);
13573 else
13574 Set_Ekind (Decl_Id, E_Variable);
13575 end if;
13576
13577 Set_Prival (Comp_Id, Decl_Id);
13578 Set_Prival_Link (Decl_Id, Comp_Id);
13579 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id));
13580
13581 -- Generate:
13582 -- comp_name : comp_typ renames _object.comp_name;
13583
13584 Decl :=
13585 Make_Object_Renaming_Declaration (Loc,
13586 Defining_Identifier => Decl_Id,
13587 Subtype_Mark =>
13588 New_Occurrence_Of (Etype (Comp_Id), Loc),
13589 Name =>
13590 Make_Selected_Component (Loc,
13591 Prefix =>
13592 New_Occurrence_Of (Obj_Ent, Loc),
13593 Selector_Name =>
13594 Make_Identifier (Loc, Chars (Comp_Id))));
13595 Add (Decl);
13596 end if;
13597
13598 Next (Comp);
13599 end loop;
13600 end;
13601 end if;
13602 end if;
13603
13604 -- Step 5: Add the declaration of the entry index and the associated
13605 -- type for barrier functions and entry families.
13606
13607 if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then
13608 declare
13609 E : constant Entity_Id := Index_Object (Spec_Id);
13610 Index : constant Entity_Id :=
13611 Defining_Identifier
13612 (Entry_Index_Specification
13613 (Entry_Body_Formal_Part (Body_Nod)));
13614 Index_Con : constant Entity_Id :=
13615 Make_Defining_Identifier (Loc, Chars (Index));
13616 High : Node_Id;
13617 Index_Typ : Entity_Id;
13618 Low : Node_Id;
13619
13620 begin
13621 -- Minimal decoration
13622
13623 Set_Ekind (Index_Con, E_Constant);
13624 Set_Entry_Index_Constant (Index, Index_Con);
13625 Set_Discriminal_Link (Index_Con, Index);
13626
13627 -- Retrieve the bounds of the entry family
13628
13629 High := Type_High_Bound (Etype (Index));
13630 Low := Type_Low_Bound (Etype (Index));
13631
13632 -- In the simple case the entry family is given by a subtype
13633 -- mark and the index constant has the same type.
13634
13635 if Is_Entity_Name (Original_Node (
13636 Discrete_Subtype_Definition (Parent (Index))))
13637 then
13638 Index_Typ := Etype (Index);
13639
13640 -- Otherwise a new subtype declaration is required
13641
13642 else
13643 High := Replace_Bound (High);
13644 Low := Replace_Bound (Low);
13645
13646 Index_Typ := Make_Temporary (Loc, 'J');
13647
13648 -- Generate:
13649 -- subtype Jnn is <Etype of Index> range Low .. High;
13650
13651 Decl :=
13652 Make_Subtype_Declaration (Loc,
13653 Defining_Identifier => Index_Typ,
13654 Subtype_Indication =>
13655 Make_Subtype_Indication (Loc,
13656 Subtype_Mark =>
13657 New_Occurrence_Of (Base_Type (Etype (Index)), Loc),
13658 Constraint =>
13659 Make_Range_Constraint (Loc,
13660 Range_Expression =>
13661 Make_Range (Loc, Low, High))));
13662 Add (Decl);
13663 end if;
13664
13665 Set_Etype (Index_Con, Index_Typ);
13666
13667 -- Create the object which designates the index:
13668 -- J : constant Jnn :=
13669 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First));
13670 --
13671 -- where Jnn is the subtype created above or the original type of
13672 -- the index, _E is a formal of the protected body subprogram and
13673 -- <index expr> is the index of the first family member.
13674
13675 Decl :=
13676 Make_Object_Declaration (Loc,
13677 Defining_Identifier => Index_Con,
13678 Constant_Present => True,
13679 Object_Definition =>
13680 New_Occurrence_Of (Index_Typ, Loc),
13681
13682 Expression =>
13683 Make_Attribute_Reference (Loc,
13684 Prefix =>
13685 New_Occurrence_Of (Index_Typ, Loc),
13686 Attribute_Name => Name_Val,
13687
13688 Expressions => New_List (
13689
13690 Make_Op_Add (Loc,
13691 Left_Opnd =>
13692 Make_Op_Subtract (Loc,
13693 Left_Opnd => New_Occurrence_Of (E, Loc),
13694 Right_Opnd =>
13695 Entry_Index_Expression (Loc,
13696 Defining_Identifier (Body_Nod),
13697 Empty, Conc_Typ)),
13698
13699 Right_Opnd =>
13700 Make_Attribute_Reference (Loc,
13701 Prefix =>
13702 New_Occurrence_Of (Index_Typ, Loc),
13703 Attribute_Name => Name_Pos,
13704 Expressions => New_List (
13705 Make_Attribute_Reference (Loc,
13706 Prefix =>
13707 New_Occurrence_Of (Index_Typ, Loc),
13708 Attribute_Name => Name_First)))))));
13709 Add (Decl);
13710 end;
13711 end if;
13712 end Install_Private_Data_Declarations;
13713
13714 -----------------------
13715 -- Is_Exception_Safe --
13716 -----------------------
13717
13718 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
13719
13720 function Has_Side_Effect (N : Node_Id) return Boolean;
13721 -- Return True whenever encountering a subprogram call or raise
13722 -- statement of any kind in the sequence of statements
13723
13724 ---------------------
13725 -- Has_Side_Effect --
13726 ---------------------
13727
13728 -- What is this doing buried two levels down in exp_ch9. It seems like a
13729 -- generally useful function, and indeed there may be code duplication
13730 -- going on here ???
13731
13732 function Has_Side_Effect (N : Node_Id) return Boolean is
13733 Stmt : Node_Id;
13734 Expr : Node_Id;
13735
13736 function Is_Call_Or_Raise (N : Node_Id) return Boolean;
13737 -- Indicate whether N is a subprogram call or a raise statement
13738
13739 ----------------------
13740 -- Is_Call_Or_Raise --
13741 ----------------------
13742
13743 function Is_Call_Or_Raise (N : Node_Id) return Boolean is
13744 begin
13745 return Nkind_In (N, N_Procedure_Call_Statement,
13746 N_Function_Call,
13747 N_Raise_Statement,
13748 N_Raise_Constraint_Error,
13749 N_Raise_Program_Error,
13750 N_Raise_Storage_Error);
13751 end Is_Call_Or_Raise;
13752
13753 -- Start of processing for Has_Side_Effect
13754
13755 begin
13756 Stmt := N;
13757 while Present (Stmt) loop
13758 if Is_Call_Or_Raise (Stmt) then
13759 return True;
13760 end if;
13761
13762 -- An object declaration can also contain a function call or a
13763 -- raise statement.
13764
13765 if Nkind (Stmt) = N_Object_Declaration then
13766 Expr := Expression (Stmt);
13767
13768 if Present (Expr) and then Is_Call_Or_Raise (Expr) then
13769 return True;
13770 end if;
13771 end if;
13772
13773 Next (Stmt);
13774 end loop;
13775
13776 return False;
13777 end Has_Side_Effect;
13778
13779 -- Start of processing for Is_Exception_Safe
13780
13781 begin
13782 -- When exceptions can't be propagated, the subprogram returns normally
13783
13784 if No_Exception_Handlers_Set then
13785 return True;
13786 end if;
13787
13788 -- If the checks handled by the back end are not disabled, we cannot
13789 -- ensure that no exception will be raised.
13790
13791 if not Access_Checks_Suppressed (Empty)
13792 or else not Discriminant_Checks_Suppressed (Empty)
13793 or else not Range_Checks_Suppressed (Empty)
13794 or else not Index_Checks_Suppressed (Empty)
13795 or else Opt.Stack_Checking_Enabled
13796 then
13797 return False;
13798 end if;
13799
13800 if Has_Side_Effect (First (Declarations (Subprogram)))
13801 or else
13802 Has_Side_Effect
13803 (First (Statements (Handled_Statement_Sequence (Subprogram))))
13804 then
13805 return False;
13806 else
13807 return True;
13808 end if;
13809 end Is_Exception_Safe;
13810
13811 ---------------------------------
13812 -- Is_Potentially_Large_Family --
13813 ---------------------------------
13814
13815 function Is_Potentially_Large_Family
13816 (Base_Index : Entity_Id;
13817 Conctyp : Entity_Id;
13818 Lo : Node_Id;
13819 Hi : Node_Id) return Boolean
13820 is
13821 begin
13822 return Scope (Base_Index) = Standard_Standard
13823 and then Base_Index = Base_Type (Standard_Integer)
13824 and then Has_Discriminants (Conctyp)
13825 and then
13826 Present (Discriminant_Default_Value (First_Discriminant (Conctyp)))
13827 and then
13828 (Denotes_Discriminant (Lo, True)
13829 or else
13830 Denotes_Discriminant (Hi, True));
13831 end Is_Potentially_Large_Family;
13832
13833 -------------------------------------
13834 -- Is_Private_Primitive_Subprogram --
13835 -------------------------------------
13836
13837 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is
13838 begin
13839 return
13840 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure)
13841 and then Is_Private_Primitive (Id);
13842 end Is_Private_Primitive_Subprogram;
13843
13844 ------------------
13845 -- Index_Object --
13846 ------------------
13847
13848 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is
13849 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id);
13850 Formal : Entity_Id;
13851
13852 begin
13853 Formal := First_Formal (Bod_Subp);
13854 while Present (Formal) loop
13855
13856 -- Look for formal parameter _E
13857
13858 if Chars (Formal) = Name_uE then
13859 return Formal;
13860 end if;
13861
13862 Next_Formal (Formal);
13863 end loop;
13864
13865 -- A protected body subprogram should always have the parameter in
13866 -- question.
13867
13868 raise Program_Error;
13869 end Index_Object;
13870
13871 --------------------------------
13872 -- Make_Initialize_Protection --
13873 --------------------------------
13874
13875 function Make_Initialize_Protection
13876 (Protect_Rec : Entity_Id) return List_Id
13877 is
13878 Loc : constant Source_Ptr := Sloc (Protect_Rec);
13879 P_Arr : Entity_Id;
13880 Pdec : Node_Id;
13881 Ptyp : constant Node_Id :=
13882 Corresponding_Concurrent_Type (Protect_Rec);
13883 Args : List_Id;
13884 L : constant List_Id := New_List;
13885 Has_Entry : constant Boolean := Has_Entries (Ptyp);
13886 Prio_Type : Entity_Id;
13887 Prio_Var : Entity_Id := Empty;
13888 Restricted : constant Boolean := Restricted_Profile;
13889
13890 begin
13891 -- We may need two calls to properly initialize the object, one to
13892 -- Initialize_Protection, and possibly one to Install_Handlers if we
13893 -- have a pragma Attach_Handler.
13894
13895 -- Get protected declaration. In the case of a task type declaration,
13896 -- this is simply the parent of the protected type entity. In the single
13897 -- protected object declaration, this parent will be the implicit type,
13898 -- and we can find the corresponding single protected object declaration
13899 -- by searching forward in the declaration list in the tree.
13900
13901 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes
13902 -- of this type should have been removed during semantic analysis.
13903
13904 Pdec := Parent (Ptyp);
13905 while not Nkind_In (Pdec, N_Protected_Type_Declaration,
13906 N_Single_Protected_Declaration)
13907 loop
13908 Next (Pdec);
13909 end loop;
13910
13911 -- Build the parameter list for the call. Note that _Init is the name
13912 -- of the formal for the object to be initialized, which is the task
13913 -- value record itself.
13914
13915 Args := New_List;
13916
13917 -- For lock-free implementation, skip initializations of the Protection
13918 -- object.
13919
13920 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
13921
13922 -- Object parameter. This is a pointer to the object of type
13923 -- Protection used by the GNARL to control the protected object.
13924
13925 Append_To (Args,
13926 Make_Attribute_Reference (Loc,
13927 Prefix =>
13928 Make_Selected_Component (Loc,
13929 Prefix => Make_Identifier (Loc, Name_uInit),
13930 Selector_Name => Make_Identifier (Loc, Name_uObject)),
13931 Attribute_Name => Name_Unchecked_Access));
13932
13933 -- Priority parameter. Set to Unspecified_Priority unless there is a
13934 -- Priority rep item, in which case we take the value from the pragma
13935 -- or attribute definition clause, or there is an Interrupt_Priority
13936 -- rep item and no Priority rep item, and we set the ceiling to
13937 -- Interrupt_Priority'Last, an implementation-defined value, see
13938 -- (RM D.3(10)).
13939
13940 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then
13941 declare
13942 Prio_Clause : constant Node_Id :=
13943 Get_Rep_Item
13944 (Ptyp, Name_Priority, Check_Parents => False);
13945
13946 Prio : Node_Id;
13947
13948 begin
13949 -- Pragma Priority
13950
13951 if Nkind (Prio_Clause) = N_Pragma then
13952 Prio :=
13953 Expression
13954 (First (Pragma_Argument_Associations (Prio_Clause)));
13955
13956 -- Get_Rep_Item returns either priority pragma.
13957
13958 if Pragma_Name (Prio_Clause) = Name_Priority then
13959 Prio_Type := RTE (RE_Any_Priority);
13960 else
13961 Prio_Type := RTE (RE_Interrupt_Priority);
13962 end if;
13963
13964 -- Attribute definition clause Priority
13965
13966 else
13967 if Chars (Prio_Clause) = Name_Priority then
13968 Prio_Type := RTE (RE_Any_Priority);
13969 else
13970 Prio_Type := RTE (RE_Interrupt_Priority);
13971 end if;
13972
13973 Prio := Expression (Prio_Clause);
13974 end if;
13975
13976 -- Always create a locale variable to capture the priority.
13977 -- The priority is also passed to Install_Restriced_Handlers.
13978 -- Note that it is really necessary to create this variable
13979 -- explicitly. It might be thought that removing side effects
13980 -- would the appropriate approach, but that could generate
13981 -- declarations improperly placed in the enclosing scope.
13982
13983 Prio_Var := Make_Temporary (Loc, 'R', Prio);
13984 Append_To (L,
13985 Make_Object_Declaration (Loc,
13986 Defining_Identifier => Prio_Var,
13987 Object_Definition => New_Occurrence_Of (Prio_Type, Loc),
13988 Expression => Relocate_Node (Prio)));
13989
13990 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc));
13991 end;
13992
13993 -- When no priority is specified but an xx_Handler pragma is, we
13994 -- default to System.Interrupts.Default_Interrupt_Priority, see
13995 -- D.3(10).
13996
13997 elsif Has_Attach_Handler (Ptyp)
13998 or else Has_Interrupt_Handler (Ptyp)
13999 then
14000 Append_To (Args,
14001 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc));
14002
14003 -- Normal case, no priority or xx_Handler specified, default priority
14004
14005 else
14006 Append_To (Args,
14007 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
14008 end if;
14009
14010 -- Test for Compiler_Info parameter. This parameter allows entry body
14011 -- procedures and barrier functions to be called from the runtime. It
14012 -- is a pointer to the record generated by the compiler to represent
14013 -- the protected object.
14014
14015 -- A protected type without entries that covers an interface and
14016 -- overrides the abstract routines with protected procedures is
14017 -- considered equivalent to a protected type with entries in the
14018 -- context of dispatching select statements.
14019
14020 -- Protected types with interrupt handlers (when not using a
14021 -- restricted profile) are also considered equivalent to protected
14022 -- types with entries.
14023
14024 -- The types which are used (Static_Interrupt_Protection and
14025 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries.
14026
14027 declare
14028 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp);
14029
14030 Called_Subp : RE_Id;
14031
14032 begin
14033 case Pkg_Id is
14034 when System_Tasking_Protected_Objects_Entries =>
14035 Called_Subp := RE_Initialize_Protection_Entries;
14036
14037 -- Argument Compiler_Info
14038
14039 Append_To (Args,
14040 Make_Attribute_Reference (Loc,
14041 Prefix => Make_Identifier (Loc, Name_uInit),
14042 Attribute_Name => Name_Address));
14043
14044 when System_Tasking_Protected_Objects_Single_Entry =>
14045 Called_Subp := RE_Initialize_Protection_Entry;
14046
14047 -- Argument Compiler_Info
14048
14049 Append_To (Args,
14050 Make_Attribute_Reference (Loc,
14051 Prefix => Make_Identifier (Loc, Name_uInit),
14052 Attribute_Name => Name_Address));
14053
14054 when System_Tasking_Protected_Objects =>
14055 Called_Subp := RE_Initialize_Protection;
14056
14057 when others =>
14058 raise Program_Error;
14059 end case;
14060
14061 -- Entry_Bodies parameter. This is a pointer to an array of
14062 -- pointers to the entry body procedures and barrier functions of
14063 -- the object. If the protected type has no entries this object
14064 -- will not exist, in this case, pass a null (it can happen when
14065 -- there are protected interrupt handlers or interfaces).
14066
14067 if Has_Entry then
14068 P_Arr := Entry_Bodies_Array (Ptyp);
14069
14070 -- Argument Entry_Body (for single entry) or Entry_Bodies (for
14071 -- multiple entries).
14072
14073 Append_To (Args,
14074 Make_Attribute_Reference (Loc,
14075 Prefix => New_Occurrence_Of (P_Arr, Loc),
14076 Attribute_Name => Name_Unrestricted_Access));
14077
14078 if Pkg_Id = System_Tasking_Protected_Objects_Entries then
14079
14080 -- Find index mapping function (clumsy but ok for now)
14081
14082 while Ekind (P_Arr) /= E_Function loop
14083 Next_Entity (P_Arr);
14084 end loop;
14085
14086 Append_To (Args,
14087 Make_Attribute_Reference (Loc,
14088 Prefix => New_Occurrence_Of (P_Arr, Loc),
14089 Attribute_Name => Name_Unrestricted_Access));
14090 end if;
14091
14092 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then
14093
14094 -- This is the case where we have a protected object with
14095 -- interfaces and no entries, and the single entry restriction
14096 -- is in effect. We pass a null pointer for the entry
14097 -- parameter because there is no actual entry.
14098
14099 Append_To (Args, Make_Null (Loc));
14100
14101 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
14102
14103 -- This is the case where we have a protected object with no
14104 -- entries and:
14105 -- - either interrupt handlers with non restricted profile,
14106 -- - or interfaces
14107 -- Note that the types which are used for interrupt handlers
14108 -- (Static/Dynamic_Interrupt_Protection) are derived from
14109 -- Protection_Entries. We pass two null pointers because there
14110 -- is no actual entry, and the initialization procedure needs
14111 -- both Entry_Bodies and Find_Body_Index.
14112
14113 Append_To (Args, Make_Null (Loc));
14114 Append_To (Args, Make_Null (Loc));
14115 end if;
14116
14117 Append_To (L,
14118 Make_Procedure_Call_Statement (Loc,
14119 Name =>
14120 New_Occurrence_Of (RTE (Called_Subp), Loc),
14121 Parameter_Associations => Args));
14122 end;
14123 end if;
14124
14125 if Has_Attach_Handler (Ptyp) then
14126
14127 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to
14128 -- make the following call:
14129
14130 -- Install_Handlers (_object,
14131 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
14132
14133 -- or, in the case of Ravenscar:
14134
14135 -- Install_Restricted_Handlers
14136 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)));
14137
14138 declare
14139 Args : constant List_Id := New_List;
14140 Table : constant List_Id := New_List;
14141 Ritem : Node_Id := First_Rep_Item (Ptyp);
14142
14143 begin
14144 -- Build the Priority parameter (only for ravenscar)
14145
14146 if Restricted then
14147
14148 -- Priority comes from a pragma
14149
14150 if Present (Prio_Var) then
14151 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc));
14152
14153 -- Priority is the default one
14154
14155 else
14156 Append_To (Args,
14157 New_Occurrence_Of
14158 (RTE (RE_Default_Interrupt_Priority), Loc));
14159 end if;
14160 end if;
14161
14162 -- Build the Attach_Handler table argument
14163
14164 while Present (Ritem) loop
14165 if Nkind (Ritem) = N_Pragma
14166 and then Pragma_Name (Ritem) = Name_Attach_Handler
14167 then
14168 declare
14169 Handler : constant Node_Id :=
14170 First (Pragma_Argument_Associations (Ritem));
14171
14172 Interrupt : constant Node_Id := Next (Handler);
14173 Expr : constant Node_Id := Expression (Interrupt);
14174
14175 begin
14176 Append_To (Table,
14177 Make_Aggregate (Loc, Expressions => New_List (
14178 Unchecked_Convert_To
14179 (RTE (RE_System_Interrupt_Id), Expr),
14180 Make_Attribute_Reference (Loc,
14181 Prefix =>
14182 Make_Selected_Component (Loc,
14183 Prefix =>
14184 Make_Identifier (Loc, Name_uInit),
14185 Selector_Name =>
14186 Duplicate_Subexpr_No_Checks
14187 (Expression (Handler))),
14188 Attribute_Name => Name_Access))));
14189 end;
14190 end if;
14191
14192 Next_Rep_Item (Ritem);
14193 end loop;
14194
14195 -- Append the table argument we just built
14196
14197 Append_To (Args, Make_Aggregate (Loc, Table));
14198
14199 -- Append the Install_Handlers (or Install_Restricted_Handlers)
14200 -- call to the statements.
14201
14202 if Restricted then
14203 -- Call a simplified version of Install_Handlers to be used
14204 -- when the Ravenscar restrictions are in effect
14205 -- (Install_Restricted_Handlers).
14206
14207 Append_To (L,
14208 Make_Procedure_Call_Statement (Loc,
14209 Name =>
14210 New_Occurrence_Of
14211 (RTE (RE_Install_Restricted_Handlers), Loc),
14212 Parameter_Associations => Args));
14213
14214 else
14215 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
14216
14217 -- First, prepends the _object argument
14218
14219 Prepend_To (Args,
14220 Make_Attribute_Reference (Loc,
14221 Prefix =>
14222 Make_Selected_Component (Loc,
14223 Prefix => Make_Identifier (Loc, Name_uInit),
14224 Selector_Name =>
14225 Make_Identifier (Loc, Name_uObject)),
14226 Attribute_Name => Name_Unchecked_Access));
14227 end if;
14228
14229 -- Then, insert call to Install_Handlers
14230
14231 Append_To (L,
14232 Make_Procedure_Call_Statement (Loc,
14233 Name =>
14234 New_Occurrence_Of (RTE (RE_Install_Handlers), Loc),
14235 Parameter_Associations => Args));
14236 end if;
14237 end;
14238 end if;
14239
14240 return L;
14241 end Make_Initialize_Protection;
14242
14243 ---------------------------
14244 -- Make_Task_Create_Call --
14245 ---------------------------
14246
14247 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is
14248 Loc : constant Source_Ptr := Sloc (Task_Rec);
14249 Args : List_Id;
14250 Ecount : Node_Id;
14251 Name : Node_Id;
14252 Tdec : Node_Id;
14253 Tdef : Node_Id;
14254 Tnam : Name_Id;
14255 Ttyp : Node_Id;
14256
14257 begin
14258 Ttyp := Corresponding_Concurrent_Type (Task_Rec);
14259 Tnam := Chars (Ttyp);
14260
14261 -- Get task declaration. In the case of a task type declaration, this is
14262 -- simply the parent of the task type entity. In the single task
14263 -- declaration, this parent will be the implicit type, and we can find
14264 -- the corresponding single task declaration by searching forward in the
14265 -- declaration list in the tree.
14266
14267 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of
14268 -- this type should have been removed during semantic analysis.
14269
14270 Tdec := Parent (Ttyp);
14271 while not Nkind_In (Tdec, N_Task_Type_Declaration,
14272 N_Single_Task_Declaration)
14273 loop
14274 Next (Tdec);
14275 end loop;
14276
14277 -- Now we can find the task definition from this declaration
14278
14279 Tdef := Task_Definition (Tdec);
14280
14281 -- Build the parameter list for the call. Note that _Init is the name
14282 -- of the formal for the object to be initialized, which is the task
14283 -- value record itself.
14284
14285 Args := New_List;
14286
14287 -- Priority parameter. Set to Unspecified_Priority unless there is a
14288 -- Priority rep item, in which case we take the value from the rep item.
14289
14290 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then
14291 Append_To (Args,
14292 Make_Selected_Component (Loc,
14293 Prefix => Make_Identifier (Loc, Name_uInit),
14294 Selector_Name => Make_Identifier (Loc, Name_uPriority)));
14295 else
14296 Append_To (Args,
14297 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc));
14298 end if;
14299
14300 -- Optional Stack parameter
14301
14302 if Restricted_Profile then
14303
14304 -- If the stack has been preallocated by the expander then
14305 -- pass its address. Otherwise, pass a null address.
14306
14307 if Preallocated_Stacks_On_Target then
14308 Append_To (Args,
14309 Make_Attribute_Reference (Loc,
14310 Prefix =>
14311 Make_Selected_Component (Loc,
14312 Prefix => Make_Identifier (Loc, Name_uInit),
14313 Selector_Name => Make_Identifier (Loc, Name_uStack)),
14314 Attribute_Name => Name_Address));
14315
14316 else
14317 Append_To (Args,
14318 New_Occurrence_Of (RTE (RE_Null_Address), Loc));
14319 end if;
14320 end if;
14321
14322 -- Size parameter. If no Storage_Size pragma is present, then
14323 -- the size is taken from the taskZ variable for the type, which
14324 -- is either Unspecified_Size, or has been reset by the use of
14325 -- a Storage_Size attribute definition clause. If a pragma is
14326 -- present, then the size is taken from the _Size field of the
14327 -- task value record, which was set from the pragma value.
14328
14329 if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then
14330 Append_To (Args,
14331 Make_Selected_Component (Loc,
14332 Prefix => Make_Identifier (Loc, Name_uInit),
14333 Selector_Name => Make_Identifier (Loc, Name_uSize)));
14334
14335 else
14336 Append_To (Args,
14337 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc));
14338 end if;
14339
14340 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
14341 -- Task_Info pragma, in which case we take the value from the pragma.
14342
14343 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then
14344 Append_To (Args,
14345 Make_Selected_Component (Loc,
14346 Prefix => Make_Identifier (Loc, Name_uInit),
14347 Selector_Name => Make_Identifier (Loc, Name_uTask_Info)));
14348
14349 else
14350 Append_To (Args,
14351 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc));
14352 end if;
14353
14354 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
14355 -- in which case we take the value from the rep item. The parameter is
14356 -- passed as an Integer because in the case of unspecified CPU the
14357 -- value is not in the range of CPU_Range.
14358
14359 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then
14360 Append_To (Args,
14361 Convert_To (Standard_Integer,
14362 Make_Selected_Component (Loc,
14363 Prefix => Make_Identifier (Loc, Name_uInit),
14364 Selector_Name => Make_Identifier (Loc, Name_uCPU))));
14365 else
14366 Append_To (Args,
14367 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc));
14368 end if;
14369
14370 if not Restricted_Profile then
14371
14372 -- Deadline parameter. If no Relative_Deadline pragma is present,
14373 -- then the deadline is Time_Span_Zero. If a pragma is present, then
14374 -- the deadline is taken from the _Relative_Deadline field of the
14375 -- task value record, which was set from the pragma value. Note that
14376 -- this parameter must not be generated for the restricted profiles
14377 -- since Ravenscar does not allow deadlines.
14378
14379 -- Case where pragma Relative_Deadline applies: use given value
14380
14381 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then
14382 Append_To (Args,
14383 Make_Selected_Component (Loc,
14384 Prefix => Make_Identifier (Loc, Name_uInit),
14385 Selector_Name =>
14386 Make_Identifier (Loc, Name_uRelative_Deadline)));
14387
14388 -- No pragma Relative_Deadline apply to the task
14389
14390 else
14391 Append_To (Args,
14392 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc));
14393 end if;
14394
14395 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
14396 -- present, then the dispatching domain is null. If a rep item is
14397 -- present, then the dispatching domain is taken from the
14398 -- _Dispatching_Domain field of the task value record, which was set
14399 -- from the rep item value.
14400
14401 -- Case where Dispatching_Domain rep item applies: use given value
14402
14403 if Has_Rep_Item
14404 (Ttyp, Name_Dispatching_Domain, Check_Parents => False)
14405 then
14406 Append_To (Args,
14407 Make_Selected_Component (Loc,
14408 Prefix =>
14409 Make_Identifier (Loc, Name_uInit),
14410 Selector_Name =>
14411 Make_Identifier (Loc, Name_uDispatching_Domain)));
14412
14413 -- No pragma or aspect Dispatching_Domain applies to the task
14414
14415 else
14416 Append_To (Args, Make_Null (Loc));
14417 end if;
14418
14419 -- Number of entries. This is an expression of the form:
14420
14421 -- n + _Init.a'Length + _Init.a'B'Length + ...
14422
14423 -- where a,b... are the entry family names for the task definition
14424
14425 Ecount :=
14426 Build_Entry_Count_Expression
14427 (Ttyp,
14428 Component_Items
14429 (Component_List
14430 (Type_Definition
14431 (Parent (Corresponding_Record_Type (Ttyp))))),
14432 Loc);
14433 Append_To (Args, Ecount);
14434
14435 -- Master parameter. This is a reference to the _Master parameter of
14436 -- the initialization procedure, except in the case of the pragma
14437 -- Restrictions (No_Task_Hierarchy) where the value is fixed to
14438 -- System.Tasking.Library_Task_Level.
14439
14440 if Restriction_Active (No_Task_Hierarchy) = False then
14441 Append_To (Args, Make_Identifier (Loc, Name_uMaster));
14442 else
14443 Append_To (Args,
14444 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
14445 end if;
14446 end if;
14447
14448 -- State parameter. This is a pointer to the task body procedure. The
14449 -- required value is obtained by taking 'Unrestricted_Access of the task
14450 -- body procedure and converting it (with an unchecked conversion) to
14451 -- the type required by the task kernel. For further details, see the
14452 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather
14453 -- than 'Address in order to avoid creating trampolines.
14454
14455 declare
14456 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp);
14457 Subp_Ptr_Typ : constant Node_Id :=
14458 Create_Itype (E_Access_Subprogram_Type, Tdec);
14459 Ref : constant Node_Id := Make_Itype_Reference (Loc);
14460
14461 begin
14462 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc);
14463 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
14464
14465 -- Be sure to freeze a reference to the access-to-subprogram type,
14466 -- otherwise gigi will complain that it's in the wrong scope, because
14467 -- it's actually inside the init procedure for the record type that
14468 -- corresponds to the task type.
14469
14470 Set_Itype (Ref, Subp_Ptr_Typ);
14471 Append_Freeze_Action (Task_Rec, Ref);
14472
14473 Append_To (Args,
14474 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access),
14475 Make_Qualified_Expression (Loc,
14476 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc),
14477 Expression =>
14478 Make_Attribute_Reference (Loc,
14479 Prefix => New_Occurrence_Of (Body_Proc, Loc),
14480 Attribute_Name => Name_Unrestricted_Access))));
14481 end;
14482
14483 -- Discriminants parameter. This is just the address of the task
14484 -- value record itself (which contains the discriminant values
14485
14486 Append_To (Args,
14487 Make_Attribute_Reference (Loc,
14488 Prefix => Make_Identifier (Loc, Name_uInit),
14489 Attribute_Name => Name_Address));
14490
14491 -- Elaborated parameter. This is an access to the elaboration Boolean
14492
14493 Append_To (Args,
14494 Make_Attribute_Reference (Loc,
14495 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')),
14496 Attribute_Name => Name_Unchecked_Access));
14497
14498 -- Add Chain parameter (not done for sequential elaboration policy, see
14499 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads).
14500
14501 if Partition_Elaboration_Policy /= 'S' then
14502 Append_To (Args, Make_Identifier (Loc, Name_uChain));
14503 end if;
14504
14505 -- Task name parameter. Take this from the _Task_Id parameter to the
14506 -- init call unless there is a Task_Name pragma, in which case we take
14507 -- the value from the pragma.
14508
14509 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then
14510 -- Copy expression in full, because it may be dynamic and have
14511 -- side effects.
14512
14513 Append_To (Args,
14514 New_Copy_Tree
14515 (Expression
14516 (First
14517 (Pragma_Argument_Associations
14518 (Get_Rep_Pragma
14519 (Ttyp, Name_Task_Name, Check_Parents => False))))));
14520
14521 else
14522 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
14523 end if;
14524
14525 -- Created_Task parameter. This is the _Task_Id field of the task
14526 -- record value
14527
14528 Append_To (Args,
14529 Make_Selected_Component (Loc,
14530 Prefix => Make_Identifier (Loc, Name_uInit),
14531 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
14532
14533 declare
14534 Create_RE : RE_Id;
14535
14536 begin
14537 if Restricted_Profile then
14538 if Partition_Elaboration_Policy = 'S' then
14539 Create_RE := RE_Create_Restricted_Task_Sequential;
14540 else
14541 Create_RE := RE_Create_Restricted_Task;
14542 end if;
14543 else
14544 Create_RE := RE_Create_Task;
14545 end if;
14546
14547 Name := New_Occurrence_Of (RTE (Create_RE), Loc);
14548 end;
14549
14550 return
14551 Make_Procedure_Call_Statement (Loc,
14552 Name => Name,
14553 Parameter_Associations => Args);
14554 end Make_Task_Create_Call;
14555
14556 ------------------------------
14557 -- Next_Protected_Operation --
14558 ------------------------------
14559
14560 function Next_Protected_Operation (N : Node_Id) return Node_Id is
14561 Next_Op : Node_Id;
14562
14563 begin
14564 -- Check whether there is a subsequent body for a protected operation
14565 -- in the current protected body. In Ada2012 that includes expression
14566 -- functions that are completions.
14567
14568 Next_Op := Next (N);
14569 while Present (Next_Op)
14570 and then not Nkind_In (Next_Op,
14571 N_Subprogram_Body, N_Entry_Body, N_Expression_Function)
14572 loop
14573 Next (Next_Op);
14574 end loop;
14575
14576 return Next_Op;
14577 end Next_Protected_Operation;
14578
14579 ---------------------
14580 -- Null_Statements --
14581 ---------------------
14582
14583 function Null_Statements (Stats : List_Id) return Boolean is
14584 Stmt : Node_Id;
14585
14586 begin
14587 Stmt := First (Stats);
14588 while Nkind (Stmt) /= N_Empty
14589 and then (Nkind_In (Stmt, N_Null_Statement, N_Label)
14590 or else
14591 (Nkind (Stmt) = N_Pragma
14592 and then
14593 Nam_In (Pragma_Name (Stmt), Name_Unreferenced,
14594 Name_Unmodified,
14595 Name_Warnings)))
14596 loop
14597 Next (Stmt);
14598 end loop;
14599
14600 return Nkind (Stmt) = N_Empty;
14601 end Null_Statements;
14602
14603 --------------------------
14604 -- Parameter_Block_Pack --
14605 --------------------------
14606
14607 function Parameter_Block_Pack
14608 (Loc : Source_Ptr;
14609 Blk_Typ : Entity_Id;
14610 Actuals : List_Id;
14611 Formals : List_Id;
14612 Decls : List_Id;
14613 Stmts : List_Id) return Node_Id
14614 is
14615 Actual : Entity_Id;
14616 Expr : Node_Id := Empty;
14617 Formal : Entity_Id;
14618 Has_Param : Boolean := False;
14619 P : Entity_Id;
14620 Params : List_Id;
14621 Temp_Asn : Node_Id;
14622 Temp_Nam : Node_Id;
14623
14624 begin
14625 Actual := First (Actuals);
14626 Formal := Defining_Identifier (First (Formals));
14627 Params := New_List;
14628 while Present (Actual) loop
14629 if Is_By_Copy_Type (Etype (Actual)) then
14630 -- Generate:
14631 -- Jnn : aliased <formal-type>
14632
14633 Temp_Nam := Make_Temporary (Loc, 'J');
14634
14635 Append_To (Decls,
14636 Make_Object_Declaration (Loc,
14637 Aliased_Present => True,
14638 Defining_Identifier => Temp_Nam,
14639 Object_Definition =>
14640 New_Occurrence_Of (Etype (Formal), Loc)));
14641
14642 if Ekind (Formal) /= E_Out_Parameter then
14643
14644 -- Generate:
14645 -- Jnn := <actual>
14646
14647 Temp_Asn :=
14648 New_Occurrence_Of (Temp_Nam, Loc);
14649
14650 Set_Assignment_OK (Temp_Asn);
14651
14652 Append_To (Stmts,
14653 Make_Assignment_Statement (Loc,
14654 Name => Temp_Asn,
14655 Expression => New_Copy_Tree (Actual)));
14656 end if;
14657
14658 -- Generate:
14659 -- Jnn'unchecked_access
14660
14661 Append_To (Params,
14662 Make_Attribute_Reference (Loc,
14663 Attribute_Name => Name_Unchecked_Access,
14664 Prefix => New_Occurrence_Of (Temp_Nam, Loc)));
14665
14666 Has_Param := True;
14667
14668 -- The controlling parameter is omitted
14669
14670 else
14671 if not Is_Controlling_Actual (Actual) then
14672 Append_To (Params,
14673 Make_Reference (Loc, New_Copy_Tree (Actual)));
14674
14675 Has_Param := True;
14676 end if;
14677 end if;
14678
14679 Next_Actual (Actual);
14680 Next_Formal_With_Extras (Formal);
14681 end loop;
14682
14683 if Has_Param then
14684 Expr := Make_Aggregate (Loc, Params);
14685 end if;
14686
14687 -- Generate:
14688 -- P : Ann := (
14689 -- J1'unchecked_access;
14690 -- <actual2>'reference;
14691 -- ...);
14692
14693 P := Make_Temporary (Loc, 'P');
14694
14695 Append_To (Decls,
14696 Make_Object_Declaration (Loc,
14697 Defining_Identifier => P,
14698 Object_Definition => New_Occurrence_Of (Blk_Typ, Loc),
14699 Expression => Expr));
14700
14701 return P;
14702 end Parameter_Block_Pack;
14703
14704 ----------------------------
14705 -- Parameter_Block_Unpack --
14706 ----------------------------
14707
14708 function Parameter_Block_Unpack
14709 (Loc : Source_Ptr;
14710 P : Entity_Id;
14711 Actuals : List_Id;
14712 Formals : List_Id) return List_Id
14713 is
14714 Actual : Entity_Id;
14715 Asnmt : Node_Id;
14716 Formal : Entity_Id;
14717 Has_Asnmt : Boolean := False;
14718 Result : constant List_Id := New_List;
14719
14720 begin
14721 Actual := First (Actuals);
14722 Formal := Defining_Identifier (First (Formals));
14723 while Present (Actual) loop
14724 if Is_By_Copy_Type (Etype (Actual))
14725 and then Ekind (Formal) /= E_In_Parameter
14726 then
14727 -- Generate:
14728 -- <actual> := P.<formal>;
14729
14730 Asnmt :=
14731 Make_Assignment_Statement (Loc,
14732 Name =>
14733 New_Copy (Actual),
14734 Expression =>
14735 Make_Explicit_Dereference (Loc,
14736 Make_Selected_Component (Loc,
14737 Prefix =>
14738 New_Occurrence_Of (P, Loc),
14739 Selector_Name =>
14740 Make_Identifier (Loc, Chars (Formal)))));
14741
14742 Set_Assignment_OK (Name (Asnmt));
14743 Append_To (Result, Asnmt);
14744
14745 Has_Asnmt := True;
14746 end if;
14747
14748 Next_Actual (Actual);
14749 Next_Formal_With_Extras (Formal);
14750 end loop;
14751
14752 if Has_Asnmt then
14753 return Result;
14754 else
14755 return New_List (Make_Null_Statement (Loc));
14756 end if;
14757 end Parameter_Block_Unpack;
14758
14759 ----------------------
14760 -- Set_Discriminals --
14761 ----------------------
14762
14763 procedure Set_Discriminals (Dec : Node_Id) is
14764 D : Entity_Id;
14765 Pdef : Entity_Id;
14766 D_Minal : Entity_Id;
14767
14768 begin
14769 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration);
14770 Pdef := Defining_Identifier (Dec);
14771
14772 if Has_Discriminants (Pdef) then
14773 D := First_Discriminant (Pdef);
14774 while Present (D) loop
14775 D_Minal :=
14776 Make_Defining_Identifier (Sloc (D),
14777 Chars => New_External_Name (Chars (D), 'D'));
14778
14779 Set_Ekind (D_Minal, E_Constant);
14780 Set_Etype (D_Minal, Etype (D));
14781 Set_Scope (D_Minal, Pdef);
14782 Set_Discriminal (D, D_Minal);
14783 Set_Discriminal_Link (D_Minal, D);
14784
14785 Next_Discriminant (D);
14786 end loop;
14787 end if;
14788 end Set_Discriminals;
14789
14790 -----------------------
14791 -- Trivial_Accept_OK --
14792 -----------------------
14793
14794 function Trivial_Accept_OK return Boolean is
14795 begin
14796 case Opt.Task_Dispatching_Policy is
14797
14798 -- If we have the default task dispatching policy in effect, we can
14799 -- definitely do the optimization (one way of looking at this is to
14800 -- think of the formal definition of the default policy being allowed
14801 -- to run any task it likes after a rendezvous, so even if notionally
14802 -- a full rescheduling occurs, we can say that our dispatching policy
14803 -- (i.e. the default dispatching policy) reorders the queue to be the
14804 -- same as just before the call.
14805
14806 when ' ' =>
14807 return True;
14808
14809 -- FIFO_Within_Priorities certainly does not permit this
14810 -- optimization since the Rendezvous is a scheduling action that may
14811 -- require some other task to be run.
14812
14813 when 'F' =>
14814 return False;
14815
14816 -- For now, disallow the optimization for all other policies. This
14817 -- may be over-conservative, but it is certainly not incorrect.
14818
14819 when others =>
14820 return False;
14821
14822 end case;
14823 end Trivial_Accept_OK;
14824
14825 end Exp_Ch9;