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-2018, 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 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Elists; use Elists; 29with Errout; use Errout; 30with Exp_Ch3; use Exp_Ch3; 31with Exp_Ch6; use Exp_Ch6; 32with Exp_Ch11; use Exp_Ch11; 33with Exp_Dbug; use Exp_Dbug; 34with Exp_Disp; use Exp_Disp; 35with Exp_Sel; use Exp_Sel; 36with Exp_Smem; use Exp_Smem; 37with Exp_Tss; use Exp_Tss; 38with Exp_Util; use Exp_Util; 39with Freeze; use Freeze; 40with Hostparm; 41with Itypes; use Itypes; 42with Namet; use Namet; 43with Nlists; use Nlists; 44with Nmake; use Nmake; 45with Opt; use Opt; 46with Restrict; use Restrict; 47with Rident; use Rident; 48with Rtsfind; use Rtsfind; 49with Sem; use Sem; 50with Sem_Aux; use Sem_Aux; 51with Sem_Ch6; use Sem_Ch6; 52with Sem_Ch8; use Sem_Ch8; 53with Sem_Ch9; use Sem_Ch9; 54with Sem_Ch11; use Sem_Ch11; 55with Sem_Elab; use Sem_Elab; 56with Sem_Eval; use Sem_Eval; 57with Sem_Res; use Sem_Res; 58with Sem_Util; use Sem_Util; 59with Sinfo; use Sinfo; 60with Snames; use Snames; 61with Stand; use Stand; 62with Targparm; use Targparm; 63with Tbuild; use Tbuild; 64with Uintp; use Uintp; 65with Validsw; use Validsw; 66 67package body Exp_Ch9 is 68 69 -- The following constant establishes the upper bound for the index of 70 -- an entry family. It is used to limit the allocated size of protected 71 -- types with defaulted discriminant of an integer type, when the bound 72 -- of some entry family depends on a discriminant. The limitation to entry 73 -- families of 128K should be reasonable in all cases, and is a documented 74 -- implementation restriction. 75 76 Entry_Family_Bound : constant Pos := 2**16; 77 78 ----------------------- 79 -- Local Subprograms -- 80 ----------------------- 81 82 function Actual_Index_Expression 83 (Sloc : Source_Ptr; 84 Ent : Entity_Id; 85 Index : Node_Id; 86 Tsk : Entity_Id) return Node_Id; 87 -- Compute the index position for an entry call. Tsk is the target task. If 88 -- the bounds of some entry family depend on discriminants, the expression 89 -- computed by this function uses the discriminants of the target task. 90 91 procedure Add_Object_Pointer 92 (Loc : Source_Ptr; 93 Conc_Typ : Entity_Id; 94 Decls : List_Id); 95 -- Prepend an object pointer declaration to the declaration list Decls. 96 -- This object pointer is initialized to a type conversion of the System. 97 -- Address pointer passed to entry barrier functions and entry body 98 -- procedures. 99 100 procedure Add_Formal_Renamings 101 (Spec : Node_Id; 102 Decls : List_Id; 103 Ent : Entity_Id; 104 Loc : Source_Ptr); 105 -- Create renaming declarations for the formals, inside the procedure that 106 -- implements an entry body. The renamings make the original names of the 107 -- formals accessible to gdb, and serve no other purpose. 108 -- Spec is the specification of the procedure being built. 109 -- Decls is the list of declarations to be enhanced. 110 -- Ent is the entity for the original entry body. 111 112 function Build_Accept_Body (Astat : Node_Id) return Node_Id; 113 -- Transform accept statement into a block with added exception handler. 114 -- Used both for simple accept statements and for accept alternatives in 115 -- select statements. Astat is the accept statement. 116 117 function Build_Barrier_Function 118 (N : Node_Id; 119 Ent : Entity_Id; 120 Pid : Node_Id) return Node_Id; 121 -- Build the function body returning the value of the barrier expression 122 -- for the specified entry body. 123 124 function Build_Barrier_Function_Specification 125 (Loc : Source_Ptr; 126 Def_Id : Entity_Id) return Node_Id; 127 -- Build a specification for a function implementing the protected entry 128 -- barrier of the specified entry body. 129 130 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id); 131 -- Build the body of a wrapper procedure for an entry or entry family that 132 -- has contract cases, preconditions, or postconditions. The body gathers 133 -- the executable contract items and expands them in the usual way, and 134 -- performs the entry call itself. This way preconditions are evaluated 135 -- before the call is queued. E is the entry in question, and Decl is the 136 -- enclosing synchronized type declaration at whose freeze point the 137 -- generated body is analyzed. 138 139 function Build_Corresponding_Record 140 (N : Node_Id; 141 Ctyp : Node_Id; 142 Loc : Source_Ptr) return Node_Id; 143 -- Common to tasks and protected types. Copy discriminant specifications, 144 -- build record declaration. N is the type declaration, Ctyp is the 145 -- concurrent entity (task type or protected type). 146 147 function Build_Dispatching_Tag_Check 148 (K : Entity_Id; 149 N : Node_Id) return Node_Id; 150 -- Utility to create the tree to check whether the dispatching call in 151 -- a timed entry call, a conditional entry call, or an asynchronous 152 -- transfer of control is a call to a primitive of a non-synchronized type. 153 -- K is the temporary that holds the tagged kind of the target object, and 154 -- N is the enclosing construct. 155 156 function Build_Entry_Count_Expression 157 (Concurrent_Type : Node_Id; 158 Component_List : List_Id; 159 Loc : Source_Ptr) return Node_Id; 160 -- Compute number of entries for concurrent object. This is a count of 161 -- simple entries, followed by an expression that computes the length 162 -- of the range of each entry family. A single array with that size is 163 -- allocated for each concurrent object of the type. 164 165 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; 166 -- Build the function that translates the entry index in the call 167 -- (which depends on the size of entry families) into an index into the 168 -- Entry_Bodies_Array, to determine the body and barrier function used 169 -- in a protected entry call. A pointer to this function appears in every 170 -- protected object. 171 172 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id; 173 -- Build subprogram declaration for previous one 174 175 function Build_Lock_Free_Protected_Subprogram_Body 176 (N : Node_Id; 177 Prot_Typ : Node_Id; 178 Unprot_Spec : Node_Id) return Node_Id; 179 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is 180 -- the subprogram specification of the unprotected version of N. Transform 181 -- N such that it invokes the unprotected version of the body. 182 183 function Build_Lock_Free_Unprotected_Subprogram_Body 184 (N : Node_Id; 185 Prot_Typ : Node_Id) return Node_Id; 186 -- N denotes a subprogram body of protected type Prot_Typ. Build a version 187 -- of N where the original statements of N are synchronized through atomic 188 -- actions such as compare and exchange. Prior to invoking this routine, it 189 -- has been established that N can be implemented in a lock-free fashion. 190 191 function Build_Parameter_Block 192 (Loc : Source_Ptr; 193 Actuals : List_Id; 194 Formals : List_Id; 195 Decls : List_Id) return Entity_Id; 196 -- Generate an access type for each actual parameter in the list Actuals. 197 -- Create an encapsulating record that contains all the actuals and return 198 -- its type. Generate: 199 -- type Ann1 is access all <actual1-type> 200 -- ... 201 -- type AnnN is access all <actualN-type> 202 -- type Pnn is record 203 -- <formal1> : Ann1; 204 -- ... 205 -- <formalN> : AnnN; 206 -- end record; 207 208 function Build_Protected_Entry 209 (N : Node_Id; 210 Ent : Entity_Id; 211 Pid : Node_Id) return Node_Id; 212 -- Build the procedure implementing the statement sequence of the specified 213 -- entry body. 214 215 function Build_Protected_Entry_Specification 216 (Loc : Source_Ptr; 217 Def_Id : Entity_Id; 218 Ent_Id : Entity_Id) return Node_Id; 219 -- Build a specification for the procedure implementing the statements of 220 -- the specified entry body. Add attributes associating it with the entry 221 -- defining identifier Ent_Id. 222 223 function Build_Protected_Spec 224 (N : Node_Id; 225 Obj_Type : Entity_Id; 226 Ident : Entity_Id; 227 Unprotected : Boolean := False) return List_Id; 228 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_ 229 -- Subprogram_Type. Builds signature of protected subprogram, adding the 230 -- formal that corresponds to the object itself. For an access to protected 231 -- subprogram, there is no object type to specify, so the parameter has 232 -- type Address and mode In. An indirect call through such a pointer will 233 -- convert the address to a reference to the actual object. The object is 234 -- a limited record and therefore a by_reference type. 235 236 function Build_Protected_Subprogram_Body 237 (N : Node_Id; 238 Pid : Node_Id; 239 N_Op_Spec : Node_Id) return Node_Id; 240 -- This function is used to construct the protected version of a protected 241 -- subprogram. Its statement sequence first defers abort, then locks the 242 -- associated protected object, and then enters a block that contains a 243 -- call to the unprotected version of the subprogram (for details, see 244 -- Build_Unprotected_Subprogram_Body). This block statement requires a 245 -- cleanup handler that unlocks the object in all cases. For details, 246 -- see Exp_Ch7.Expand_Cleanup_Actions. 247 248 function Build_Renamed_Formal_Declaration 249 (New_F : Entity_Id; 250 Formal : Entity_Id; 251 Comp : Entity_Id; 252 Renamed_Formal : Node_Id) return Node_Id; 253 -- Create a renaming declaration for a formal, within a protected entry 254 -- body or an accept body. The renamed object is a component of the 255 -- parameter block that is a parameter in the entry call. 256 -- 257 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming 258 -- does not dereference the corresponding component to prevent an illegal 259 -- use of the incomplete type (AI05-0151). 260 261 function Build_Selected_Name 262 (Prefix : Entity_Id; 263 Selector : Entity_Id; 264 Append_Char : Character := ' ') return Name_Id; 265 -- Build a name in the form of Prefix__Selector, with an optional character 266 -- appended. This is used for internal subprograms generated for operations 267 -- of protected types, including barrier functions. For the subprograms 268 -- generated for entry bodies and entry barriers, the generated name 269 -- includes a sequence number that makes names unique in the presence of 270 -- entry overloading. This is necessary because entry body procedures and 271 -- barrier functions all have the same signature. 272 273 procedure Build_Simple_Entry_Call 274 (N : Node_Id; 275 Concval : Node_Id; 276 Ename : Node_Id; 277 Index : Node_Id); 278 -- Some comments here would be useful ??? 279 280 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id; 281 -- This routine constructs a specification for the procedure that we will 282 -- build for the task body for task type T. The spec has the form: 283 -- 284 -- procedure tnameB (_Task : access tnameV); 285 -- 286 -- where name is the character name taken from the task type entity that 287 -- is passed as the argument to the procedure, and tnameV is the task 288 -- value type that is associated with the task type. 289 290 function Build_Unprotected_Subprogram_Body 291 (N : Node_Id; 292 Pid : Node_Id) return Node_Id; 293 -- This routine constructs the unprotected version of a protected 294 -- subprogram body, which is contains all of the code in the original, 295 -- unexpanded body. This is the version of the protected subprogram that is 296 -- called from all protected operations on the same object, including the 297 -- protected version of the same subprogram. 298 299 procedure Build_Wrapper_Bodies 300 (Loc : Source_Ptr; 301 Typ : Entity_Id; 302 N : Node_Id); 303 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding 304 -- record of a concurrent type. N is the insertion node where all bodies 305 -- will be placed. This routine builds the bodies of the subprograms which 306 -- serve as an indirection mechanism to overriding primitives of concurrent 307 -- types, entries and protected procedures. Any new body is analyzed. 308 309 procedure Build_Wrapper_Specs 310 (Loc : Source_Ptr; 311 Typ : Entity_Id; 312 N : in out Node_Id); 313 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding 314 -- record of a concurrent type. N is the insertion node where all specs 315 -- will be placed. This routine builds the specs of the subprograms which 316 -- serve as an indirection mechanism to overriding primitives of concurrent 317 -- types, entries and protected procedures. Any new spec is analyzed. 318 319 procedure Collect_Entry_Families 320 (Loc : Source_Ptr; 321 Cdecls : List_Id; 322 Current_Node : in out Node_Id; 323 Conctyp : Entity_Id); 324 -- For each entry family in a concurrent type, create an anonymous array 325 -- type of the right size, and add a component to the corresponding_record. 326 327 function Concurrent_Object 328 (Spec_Id : Entity_Id; 329 Conc_Typ : Entity_Id) return Entity_Id; 330 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return 331 -- the entity associated with the concurrent object in the Protected_Body_ 332 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity 333 -- denotes formal parameter _O, _object or _task. 334 335 function Copy_Result_Type (Res : Node_Id) return Node_Id; 336 -- Copy the result type of a function specification, when building the 337 -- internal operation corresponding to a protected function, or when 338 -- expanding an access to protected function. If the result is an anonymous 339 -- access to subprogram itself, we need to create a new signature with the 340 -- same parameter names and the same resolved types, but with new entities 341 -- for the formals. 342 343 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean; 344 -- Return whether a secondary stack for the task T should be created by the 345 -- expander. The secondary stack for a task will be created by the expander 346 -- if the size of the stack has been specified by the Secondary_Stack_Size 347 -- representation aspect and either the No_Implicit_Heap_Allocations or 348 -- No_Implicit_Task_Allocations restrictions are in effect and the 349 -- No_Secondary_Stack restriction is not. 350 351 procedure Debug_Private_Data_Declarations (Decls : List_Id); 352 -- Decls is a list which may contain the declarations created by Install_ 353 -- Private_Data_Declarations. All generated entities are marked as needing 354 -- debug info and debug nodes are manually generation where necessary. This 355 -- step of the expansion must to be done after private data has been moved 356 -- to its final resting scope to ensure proper visibility of debug objects. 357 358 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id); 359 -- If control flow optimizations are suppressed, and Alt is an accept, 360 -- delay, or entry call alternative with no trailing statements, insert 361 -- a null trailing statement with the given Loc (which is the sloc of 362 -- the accept, delay, or entry call statement). There might not be any 363 -- generated code for the accept, delay, or entry call itself (the effect 364 -- of these statements is part of the general processsing done for the 365 -- enclosing selective accept, timed entry call, or asynchronous select), 366 -- and the null statement is there to carry the sloc of that statement to 367 -- the back-end for trace-based coverage analysis purposes. 368 369 procedure Extract_Dispatching_Call 370 (N : Node_Id; 371 Call_Ent : out Entity_Id; 372 Object : out Entity_Id; 373 Actuals : out List_Id; 374 Formals : out List_Id); 375 -- Given a dispatching call, extract the entity of the name of the call, 376 -- its actual dispatching object, its actual parameters and the formal 377 -- parameters of the overridden interface-level version. If the type of 378 -- the dispatching object is an access type then an explicit dereference 379 -- is returned in Object. 380 381 procedure Extract_Entry 382 (N : Node_Id; 383 Concval : out Node_Id; 384 Ename : out Node_Id; 385 Index : out Node_Id); 386 -- Given an entry call, returns the associated concurrent object, the entry 387 -- name, and the entry family index. 388 389 function Family_Offset 390 (Loc : Source_Ptr; 391 Hi : Node_Id; 392 Lo : Node_Id; 393 Ttyp : Entity_Id; 394 Cap : Boolean) return Node_Id; 395 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an 396 -- accept statement, or the upper bound in the discrete subtype of an entry 397 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent 398 -- type of the entry. If Cap is true, the result is capped according to 399 -- Entry_Family_Bound. 400 401 function Family_Size 402 (Loc : Source_Ptr; 403 Hi : Node_Id; 404 Lo : Node_Id; 405 Ttyp : Entity_Id; 406 Cap : Boolean) return Node_Id; 407 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a 408 -- family, and handle properly the superflat case. This is equivalent to 409 -- the use of 'Length on the index type, but must use Family_Offset to 410 -- handle properly the case of bounds that depend on discriminants. If 411 -- Cap is true, the result is capped according to Entry_Family_Bound. 412 413 procedure Find_Enclosing_Context 414 (N : Node_Id; 415 Context : out Node_Id; 416 Context_Id : out Entity_Id; 417 Context_Decls : out List_Id); 418 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and 419 -- Build_Master_Entity. Given an arbitrary node in the tree, find the 420 -- nearest enclosing body, block, package, or return statement and return 421 -- its constituents. Context is the enclosing construct, Context_Id is 422 -- the scope of Context_Id and Context_Decls is the declarative list of 423 -- Context. 424 425 function Index_Object (Spec_Id : Entity_Id) return Entity_Id; 426 -- Given a subprogram identifier, return the entity which is associated 427 -- with the protection entry index in the Protected_Body_Subprogram or 428 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal 429 -- parameter _E. 430 431 function Is_Potentially_Large_Family 432 (Base_Index : Entity_Id; 433 Conctyp : Entity_Id; 434 Lo : Node_Id; 435 Hi : Node_Id) return Boolean; 436 437 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean; 438 -- Determine whether Id is a function or a procedure and is marked as a 439 -- private primitive. 440 441 function Null_Statements (Stats : List_Id) return Boolean; 442 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. 443 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well 444 -- to still count as null. Returns True for a null sequence. The argument 445 -- is the list of statements from the DO-END sequence. 446 447 function Parameter_Block_Pack 448 (Loc : Source_Ptr; 449 Blk_Typ : Entity_Id; 450 Actuals : List_Id; 451 Formals : List_Id; 452 Decls : List_Id; 453 Stmts : List_Id) return Entity_Id; 454 -- Set the components of the generated parameter block with the values 455 -- of the actual parameters. Generate aliased temporaries to capture the 456 -- values for types that are passed by copy. Otherwise generate a reference 457 -- to the actual's value. Return the address of the aggregate block. 458 -- Generate: 459 -- Jnn1 : alias <formal-type1>; 460 -- Jnn1 := <actual1>; 461 -- ... 462 -- P : Blk_Typ := ( 463 -- Jnn1'unchecked_access; 464 -- <actual2>'reference; 465 -- ...); 466 467 function Parameter_Block_Unpack 468 (Loc : Source_Ptr; 469 P : Entity_Id; 470 Actuals : List_Id; 471 Formals : List_Id) return List_Id; 472 -- Retrieve the values of the components from the parameter block and 473 -- assign then to the original actual parameters. Generate: 474 -- <actual1> := P.<formal1>; 475 -- ... 476 -- <actualN> := P.<formalN>; 477 478 function Trivial_Accept_OK return Boolean; 479 -- If there is no DO-END block for an accept, or if the DO-END block has 480 -- only null statements, then it is possible to do the Rendezvous with much 481 -- less overhead using the Accept_Trivial routine in the run-time library. 482 -- However, this is not always a valid optimization. Whether it is valid or 483 -- not depends on the Task_Dispatching_Policy. The issue is whether a full 484 -- rescheduling action is required or not. In FIFO_Within_Priorities, such 485 -- a rescheduling is required, so this optimization is not allowed. This 486 -- function returns True if the optimization is permitted. 487 488 ----------------------------- 489 -- Actual_Index_Expression -- 490 ----------------------------- 491 492 function Actual_Index_Expression 493 (Sloc : Source_Ptr; 494 Ent : Entity_Id; 495 Index : Node_Id; 496 Tsk : Entity_Id) return Node_Id 497 is 498 Ttyp : constant Entity_Id := Etype (Tsk); 499 Expr : Node_Id; 500 Num : Node_Id; 501 Lo : Node_Id; 502 Hi : Node_Id; 503 Prev : Entity_Id; 504 S : Node_Id; 505 506 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id; 507 -- Compute difference between bounds of entry family 508 509 -------------------------- 510 -- Actual_Family_Offset -- 511 -------------------------- 512 513 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is 514 515 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; 516 -- Replace a reference to a discriminant with a selected component 517 -- denoting the discriminant of the target task. 518 519 ----------------------------- 520 -- Actual_Discriminant_Ref -- 521 ----------------------------- 522 523 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is 524 Typ : constant Entity_Id := Etype (Bound); 525 B : Node_Id; 526 527 begin 528 if not Is_Entity_Name (Bound) 529 or else Ekind (Entity (Bound)) /= E_Discriminant 530 then 531 if Nkind (Bound) = N_Attribute_Reference then 532 return Bound; 533 else 534 B := New_Copy_Tree (Bound); 535 end if; 536 537 else 538 B := 539 Make_Selected_Component (Sloc, 540 Prefix => New_Copy_Tree (Tsk), 541 Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc)); 542 543 Analyze_And_Resolve (B, Typ); 544 end if; 545 546 return 547 Make_Attribute_Reference (Sloc, 548 Attribute_Name => Name_Pos, 549 Prefix => New_Occurrence_Of (Etype (Bound), Sloc), 550 Expressions => New_List (B)); 551 end Actual_Discriminant_Ref; 552 553 -- Start of processing for Actual_Family_Offset 554 555 begin 556 return 557 Make_Op_Subtract (Sloc, 558 Left_Opnd => Actual_Discriminant_Ref (Hi), 559 Right_Opnd => Actual_Discriminant_Ref (Lo)); 560 end Actual_Family_Offset; 561 562 -- Start of processing for Actual_Index_Expression 563 564 begin 565 -- The queues of entries and entry families appear in textual order in 566 -- the associated record. The entry index is computed as the sum of the 567 -- number of queues for all entries that precede the designated one, to 568 -- which is added the index expression, if this expression denotes a 569 -- member of a family. 570 571 -- The following is a place holder for the count of simple entries 572 573 Num := Make_Integer_Literal (Sloc, 1); 574 575 -- We construct an expression which is a series of addition operations. 576 -- See comments in Entry_Index_Expression, which is identical in 577 -- structure. 578 579 if Present (Index) then 580 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); 581 582 Expr := 583 Make_Op_Add (Sloc, 584 Left_Opnd => Num, 585 Right_Opnd => 586 Actual_Family_Offset ( 587 Make_Attribute_Reference (Sloc, 588 Attribute_Name => Name_Pos, 589 Prefix => New_Occurrence_Of (Base_Type (S), Sloc), 590 Expressions => New_List (Relocate_Node (Index))), 591 Type_Low_Bound (S))); 592 else 593 Expr := Num; 594 end if; 595 596 -- Now add lengths of preceding entries and entry families 597 598 Prev := First_Entity (Ttyp); 599 while Chars (Prev) /= Chars (Ent) 600 or else (Ekind (Prev) /= Ekind (Ent)) 601 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 602 loop 603 if Ekind (Prev) = E_Entry then 604 Set_Intval (Num, Intval (Num) + 1); 605 606 elsif Ekind (Prev) = E_Entry_Family then 607 S := 608 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 609 610 -- The need for the following full view retrieval stems from this 611 -- complex case of nested generics and tasking: 612 613 -- generic 614 -- type Formal_Index is range <>; 615 -- ... 616 -- package Outer is 617 -- type Index is private; 618 -- generic 619 -- ... 620 -- package Inner is 621 -- procedure P; 622 -- end Inner; 623 -- private 624 -- type Index is new Formal_Index range 1 .. 10; 625 -- end Outer; 626 627 -- package body Outer is 628 -- task type T is 629 -- entry Fam (Index); -- (2) 630 -- entry E; 631 -- end T; 632 -- package body Inner is -- (3) 633 -- procedure P is 634 -- begin 635 -- T.E; -- (1) 636 -- end P; 637 -- end Inner; 638 -- ... 639 640 -- We are currently building the index expression for the entry 641 -- call "T.E" (1). Part of the expansion must mention the range 642 -- of the discrete type "Index" (2) of entry family "Fam". 643 644 -- However only the private view of type "Index" is available to 645 -- the inner generic (3) because there was no prior mention of 646 -- the type inside "Inner". This visibility requirement is 647 -- implicit and cannot be detected during the construction of 648 -- the generic trees and needs special handling. 649 650 if In_Instance_Body 651 and then Is_Private_Type (S) 652 and then Present (Full_View (S)) 653 then 654 S := Full_View (S); 655 end if; 656 657 Lo := Type_Low_Bound (S); 658 Hi := Type_High_Bound (S); 659 660 Expr := 661 Make_Op_Add (Sloc, 662 Left_Opnd => Expr, 663 Right_Opnd => 664 Make_Op_Add (Sloc, 665 Left_Opnd => Actual_Family_Offset (Hi, Lo), 666 Right_Opnd => Make_Integer_Literal (Sloc, 1))); 667 668 -- Other components are anonymous types to be ignored 669 670 else 671 null; 672 end if; 673 674 Next_Entity (Prev); 675 end loop; 676 677 return Expr; 678 end Actual_Index_Expression; 679 680 -------------------------- 681 -- Add_Formal_Renamings -- 682 -------------------------- 683 684 procedure Add_Formal_Renamings 685 (Spec : Node_Id; 686 Decls : List_Id; 687 Ent : Entity_Id; 688 Loc : Source_Ptr) 689 is 690 Ptr : constant Entity_Id := 691 Defining_Identifier 692 (Next (First (Parameter_Specifications (Spec)))); 693 -- The name of the formal that holds the address of the parameter block 694 -- for the call. 695 696 Comp : Entity_Id; 697 Decl : Node_Id; 698 Formal : Entity_Id; 699 New_F : Entity_Id; 700 Renamed_Formal : Node_Id; 701 702 begin 703 Formal := First_Formal (Ent); 704 while Present (Formal) loop 705 Comp := Entry_Component (Formal); 706 New_F := 707 Make_Defining_Identifier (Sloc (Formal), 708 Chars => Chars (Formal)); 709 Set_Etype (New_F, Etype (Formal)); 710 Set_Scope (New_F, Ent); 711 712 -- Now we set debug info needed on New_F even though it does not come 713 -- from source, so that the debugger will get the right information 714 -- for these generated names. 715 716 Set_Debug_Info_Needed (New_F); 717 718 if Ekind (Formal) = E_In_Parameter then 719 Set_Ekind (New_F, E_Constant); 720 else 721 Set_Ekind (New_F, E_Variable); 722 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 723 end if; 724 725 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 726 727 Renamed_Formal := 728 Make_Selected_Component (Loc, 729 Prefix => 730 Unchecked_Convert_To (Entry_Parameters_Type (Ent), 731 Make_Identifier (Loc, Chars (Ptr))), 732 Selector_Name => New_Occurrence_Of (Comp, Loc)); 733 734 Decl := 735 Build_Renamed_Formal_Declaration 736 (New_F, Formal, Comp, Renamed_Formal); 737 738 Append (Decl, Decls); 739 Set_Renamed_Object (Formal, New_F); 740 Next_Formal (Formal); 741 end loop; 742 end Add_Formal_Renamings; 743 744 ------------------------ 745 -- Add_Object_Pointer -- 746 ------------------------ 747 748 procedure Add_Object_Pointer 749 (Loc : Source_Ptr; 750 Conc_Typ : Entity_Id; 751 Decls : List_Id) 752 is 753 Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ); 754 Decl : Node_Id; 755 Obj_Ptr : Node_Id; 756 757 begin 758 -- Create the renaming declaration for the Protection object of a 759 -- protected type. _Object is used by Complete_Entry_Body. 760 -- ??? An attempt to make this a renaming was unsuccessful. 761 762 -- Build the entity for the access type 763 764 Obj_Ptr := 765 Make_Defining_Identifier (Loc, 766 New_External_Name (Chars (Rec_Typ), 'P')); 767 768 -- Generate: 769 -- _object : poVP := poVP!O; 770 771 Decl := 772 Make_Object_Declaration (Loc, 773 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uObject), 774 Object_Definition => New_Occurrence_Of (Obj_Ptr, Loc), 775 Expression => 776 Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO))); 777 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 778 Prepend_To (Decls, Decl); 779 780 -- Generate: 781 -- type poVP is access poV; 782 783 Decl := 784 Make_Full_Type_Declaration (Loc, 785 Defining_Identifier => 786 Obj_Ptr, 787 Type_Definition => 788 Make_Access_To_Object_Definition (Loc, 789 Subtype_Indication => 790 New_Occurrence_Of (Rec_Typ, Loc))); 791 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 792 Prepend_To (Decls, Decl); 793 end Add_Object_Pointer; 794 795 ----------------------- 796 -- Build_Accept_Body -- 797 ----------------------- 798 799 function Build_Accept_Body (Astat : Node_Id) return Node_Id is 800 Loc : constant Source_Ptr := Sloc (Astat); 801 Stats : constant Node_Id := Handled_Statement_Sequence (Astat); 802 New_S : Node_Id; 803 Hand : Node_Id; 804 Call : Node_Id; 805 Ohandle : Node_Id; 806 807 begin 808 -- At the end of the statement sequence, Complete_Rendezvous is called. 809 -- A label skipping the Complete_Rendezvous, and all other accept 810 -- processing, has already been added for the expansion of requeue 811 -- statements. The Sloc is copied from the last statement since it 812 -- is really part of this last statement. 813 814 Call := 815 Build_Runtime_Call 816 (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous); 817 Insert_Before (Last (Statements (Stats)), Call); 818 Analyze (Call); 819 820 -- If exception handlers are present, then append Complete_Rendezvous 821 -- calls to the handlers, and construct the required outer block. As 822 -- above, the Sloc is copied from the last statement in the sequence. 823 824 if Present (Exception_Handlers (Stats)) then 825 Hand := First (Exception_Handlers (Stats)); 826 while Present (Hand) loop 827 Call := 828 Build_Runtime_Call 829 (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous); 830 Append (Call, Statements (Hand)); 831 Analyze (Call); 832 Next (Hand); 833 end loop; 834 835 New_S := 836 Make_Handled_Sequence_Of_Statements (Loc, 837 Statements => New_List ( 838 Make_Block_Statement (Loc, 839 Handled_Statement_Sequence => Stats))); 840 841 else 842 New_S := Stats; 843 end if; 844 845 -- At this stage we know that the new statement sequence does 846 -- not have an exception handler part, so we supply one to call 847 -- Exceptional_Complete_Rendezvous. This handler is 848 849 -- when all others => 850 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 851 852 -- We handle Abort_Signal to make sure that we properly catch the abort 853 -- case and wake up the caller. 854 855 Ohandle := Make_Others_Choice (Loc); 856 Set_All_Others (Ohandle); 857 858 Set_Exception_Handlers (New_S, 859 New_List ( 860 Make_Implicit_Exception_Handler (Loc, 861 Exception_Choices => New_List (Ohandle), 862 863 Statements => New_List ( 864 Make_Procedure_Call_Statement (Sloc (Stats), 865 Name => New_Occurrence_Of ( 866 RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)), 867 Parameter_Associations => New_List ( 868 Make_Function_Call (Sloc (Stats), 869 Name => 870 New_Occurrence_Of 871 (RTE (RE_Get_GNAT_Exception), Sloc (Stats))))))))); 872 873 Set_Parent (New_S, Astat); -- temp parent for Analyze call 874 Analyze_Exception_Handlers (Exception_Handlers (New_S)); 875 Expand_Exception_Handlers (New_S); 876 877 -- Exceptional_Complete_Rendezvous must be called with abort still 878 -- deferred, which is the case for a "when all others" handler. 879 880 return New_S; 881 end Build_Accept_Body; 882 883 ----------------------------------- 884 -- Build_Activation_Chain_Entity -- 885 ----------------------------------- 886 887 procedure Build_Activation_Chain_Entity (N : Node_Id) is 888 function Has_Activation_Chain (Stmt : Node_Id) return Boolean; 889 -- Determine whether an extended return statement has activation chain 890 891 -------------------------- 892 -- Has_Activation_Chain -- 893 -------------------------- 894 895 function Has_Activation_Chain (Stmt : Node_Id) return Boolean is 896 Decl : Node_Id; 897 898 begin 899 Decl := First (Return_Object_Declarations (Stmt)); 900 while Present (Decl) loop 901 if Nkind (Decl) = N_Object_Declaration 902 and then Chars (Defining_Identifier (Decl)) = Name_uChain 903 then 904 return True; 905 end if; 906 907 Next (Decl); 908 end loop; 909 910 return False; 911 end Has_Activation_Chain; 912 913 -- Local variables 914 915 Context : Node_Id; 916 Context_Id : Entity_Id; 917 Decls : List_Id; 918 919 -- Start of processing for Build_Activation_Chain_Entity 920 921 begin 922 -- Activation chain is never used for sequential elaboration policy, see 923 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 924 925 if Partition_Elaboration_Policy = 'S' then 926 return; 927 end if; 928 929 Find_Enclosing_Context (N, Context, Context_Id, Decls); 930 931 -- If activation chain entity has not been declared already, create one 932 933 if Nkind (Context) = N_Extended_Return_Statement 934 or else No (Activation_Chain_Entity (Context)) 935 then 936 -- Since extended return statements do not store the entity of the 937 -- chain, examine the return object declarations to avoid creating 938 -- a duplicate. 939 940 if Nkind (Context) = N_Extended_Return_Statement 941 and then Has_Activation_Chain (Context) 942 then 943 return; 944 end if; 945 946 declare 947 Loc : constant Source_Ptr := Sloc (Context); 948 Chain : Entity_Id; 949 Decl : Node_Id; 950 951 begin 952 Chain := Make_Defining_Identifier (Sloc (N), Name_uChain); 953 954 -- Note: An extended return statement is not really a task 955 -- activator, but it does have an activation chain on which to 956 -- store the tasks temporarily. On successful return, the tasks 957 -- on this chain are moved to the chain passed in by the caller. 958 -- We do not build an Activation_Chain_Entity for an extended 959 -- return statement, because we do not want to build a call to 960 -- Activate_Tasks. Task activation is the responsibility of the 961 -- caller. 962 963 if Nkind (Context) /= N_Extended_Return_Statement then 964 Set_Activation_Chain_Entity (Context, Chain); 965 end if; 966 967 Decl := 968 Make_Object_Declaration (Loc, 969 Defining_Identifier => Chain, 970 Aliased_Present => True, 971 Object_Definition => 972 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)); 973 974 Prepend_To (Decls, Decl); 975 976 -- Ensure that _chain appears in the proper scope of the context 977 978 if Context_Id /= Current_Scope then 979 Push_Scope (Context_Id); 980 Analyze (Decl); 981 Pop_Scope; 982 else 983 Analyze (Decl); 984 end if; 985 end; 986 end if; 987 end Build_Activation_Chain_Entity; 988 989 ---------------------------- 990 -- Build_Barrier_Function -- 991 ---------------------------- 992 993 function Build_Barrier_Function 994 (N : Node_Id; 995 Ent : Entity_Id; 996 Pid : Node_Id) return Node_Id 997 is 998 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); 999 Cond : constant Node_Id := Condition (Ent_Formals); 1000 Loc : constant Source_Ptr := Sloc (Cond); 1001 Func_Id : constant Entity_Id := Barrier_Function (Ent); 1002 Op_Decls : constant List_Id := New_List; 1003 Stmt : Node_Id; 1004 Func_Body : Node_Id; 1005 1006 begin 1007 -- Add a declaration for the Protection object, renaming declarations 1008 -- for the discriminals and privals and finally a declaration for the 1009 -- entry family index (if applicable). 1010 1011 Install_Private_Data_Declarations (Sloc (N), 1012 Spec_Id => Func_Id, 1013 Conc_Typ => Pid, 1014 Body_Nod => N, 1015 Decls => Op_Decls, 1016 Barrier => True, 1017 Family => Ekind (Ent) = E_Entry_Family); 1018 1019 -- If compiling with -fpreserve-control-flow, make sure we insert an 1020 -- IF statement so that the back-end knows to generate a conditional 1021 -- branch instruction, even if the condition is just the name of a 1022 -- boolean object. Note that Expand_N_If_Statement knows to preserve 1023 -- such redundant IF statements under -fpreserve-control-flow 1024 -- (whether coming from this routine, or directly from source). 1025 1026 if Opt.Suppress_Control_Flow_Optimizations then 1027 Stmt := 1028 Make_Implicit_If_Statement (Cond, 1029 Condition => Cond, 1030 Then_Statements => New_List ( 1031 Make_Simple_Return_Statement (Loc, 1032 New_Occurrence_Of (Standard_True, Loc))), 1033 1034 Else_Statements => New_List ( 1035 Make_Simple_Return_Statement (Loc, 1036 New_Occurrence_Of (Standard_False, Loc)))); 1037 1038 else 1039 Stmt := Make_Simple_Return_Statement (Loc, Cond); 1040 end if; 1041 1042 -- Note: the condition in the barrier function needs to be properly 1043 -- processed for the C/Fortran boolean possibility, but this happens 1044 -- automatically since the return statement does this normalization. 1045 1046 Func_Body := 1047 Make_Subprogram_Body (Loc, 1048 Specification => 1049 Build_Barrier_Function_Specification (Loc, 1050 Make_Defining_Identifier (Loc, Chars (Func_Id))), 1051 Declarations => Op_Decls, 1052 Handled_Statement_Sequence => 1053 Make_Handled_Sequence_Of_Statements (Loc, 1054 Statements => New_List (Stmt))); 1055 Set_Is_Entry_Barrier_Function (Func_Body); 1056 1057 return Func_Body; 1058 end Build_Barrier_Function; 1059 1060 ------------------------------------------ 1061 -- Build_Barrier_Function_Specification -- 1062 ------------------------------------------ 1063 1064 function Build_Barrier_Function_Specification 1065 (Loc : Source_Ptr; 1066 Def_Id : Entity_Id) return Node_Id 1067 is 1068 begin 1069 Set_Debug_Info_Needed (Def_Id); 1070 1071 return 1072 Make_Function_Specification (Loc, 1073 Defining_Unit_Name => Def_Id, 1074 Parameter_Specifications => New_List ( 1075 Make_Parameter_Specification (Loc, 1076 Defining_Identifier => 1077 Make_Defining_Identifier (Loc, Name_uO), 1078 Parameter_Type => 1079 New_Occurrence_Of (RTE (RE_Address), Loc)), 1080 1081 Make_Parameter_Specification (Loc, 1082 Defining_Identifier => 1083 Make_Defining_Identifier (Loc, Name_uE), 1084 Parameter_Type => 1085 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), 1086 1087 Result_Definition => 1088 New_Occurrence_Of (Standard_Boolean, Loc)); 1089 end Build_Barrier_Function_Specification; 1090 1091 -------------------------- 1092 -- Build_Call_With_Task -- 1093 -------------------------- 1094 1095 function Build_Call_With_Task 1096 (N : Node_Id; 1097 E : Entity_Id) return Node_Id 1098 is 1099 Loc : constant Source_Ptr := Sloc (N); 1100 begin 1101 return 1102 Make_Function_Call (Loc, 1103 Name => New_Occurrence_Of (E, Loc), 1104 Parameter_Associations => New_List (Concurrent_Ref (N))); 1105 end Build_Call_With_Task; 1106 1107 ----------------------------- 1108 -- Build_Class_Wide_Master -- 1109 ----------------------------- 1110 1111 procedure Build_Class_Wide_Master (Typ : Entity_Id) is 1112 Loc : constant Source_Ptr := Sloc (Typ); 1113 Master_Decl : Node_Id; 1114 Master_Id : Entity_Id; 1115 Master_Scope : Entity_Id; 1116 Name_Id : Node_Id; 1117 Related_Node : Node_Id; 1118 Ren_Decl : Node_Id; 1119 1120 begin 1121 -- Nothing to do if there is no task hierarchy 1122 1123 if Restriction_Active (No_Task_Hierarchy) then 1124 return; 1125 end if; 1126 1127 -- Find the declaration that created the access type, which is either a 1128 -- type declaration, or an object declaration with an access definition, 1129 -- in which case the type is anonymous. 1130 1131 if Is_Itype (Typ) then 1132 Related_Node := Associated_Node_For_Itype (Typ); 1133 else 1134 Related_Node := Parent (Typ); 1135 end if; 1136 1137 Master_Scope := Find_Master_Scope (Typ); 1138 1139 -- Nothing to do if the master scope already contains a _master entity. 1140 -- The only exception to this is the following scenario: 1141 1142 -- Source_Scope 1143 -- Transient_Scope_1 1144 -- _master 1145 1146 -- Transient_Scope_2 1147 -- use of master 1148 1149 -- In this case the source scope is marked as having the master entity 1150 -- even though the actual declaration appears inside an inner scope. If 1151 -- the second transient scope requires a _master, it cannot use the one 1152 -- already declared because the entity is not visible. 1153 1154 Name_Id := Make_Identifier (Loc, Name_uMaster); 1155 Master_Decl := Empty; 1156 1157 if not Has_Master_Entity (Master_Scope) 1158 or else No (Current_Entity_In_Scope (Name_Id)) 1159 then 1160 begin 1161 Set_Has_Master_Entity (Master_Scope); 1162 1163 -- Generate: 1164 -- _master : constant Integer := Current_Master.all; 1165 1166 Master_Decl := 1167 Make_Object_Declaration (Loc, 1168 Defining_Identifier => 1169 Make_Defining_Identifier (Loc, Name_uMaster), 1170 Constant_Present => True, 1171 Object_Definition => 1172 New_Occurrence_Of (Standard_Integer, Loc), 1173 Expression => 1174 Make_Explicit_Dereference (Loc, 1175 New_Occurrence_Of (RTE (RE_Current_Master), Loc))); 1176 1177 Insert_Action (Find_Hook_Context (Related_Node), Master_Decl); 1178 Analyze (Master_Decl); 1179 1180 -- Mark the containing scope as a task master. Masters associated 1181 -- with return statements are already marked at this stage (see 1182 -- Analyze_Subprogram_Body). 1183 1184 if Ekind (Current_Scope) /= E_Return_Statement then 1185 declare 1186 Par : Node_Id := Related_Node; 1187 1188 begin 1189 while Nkind (Par) /= N_Compilation_Unit loop 1190 Par := Parent (Par); 1191 1192 -- If we fall off the top, we are at the outer level, 1193 -- and the environment task is our effective master, 1194 -- so nothing to mark. 1195 1196 if Nkind_In (Par, N_Block_Statement, 1197 N_Subprogram_Body, 1198 N_Task_Body) 1199 then 1200 Set_Is_Task_Master (Par); 1201 exit; 1202 end if; 1203 end loop; 1204 end; 1205 end if; 1206 end; 1207 end if; 1208 1209 Master_Id := 1210 Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'M')); 1211 1212 -- Generate: 1213 -- typeMnn renames _master; 1214 1215 Ren_Decl := 1216 Make_Object_Renaming_Declaration (Loc, 1217 Defining_Identifier => Master_Id, 1218 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), 1219 Name => Name_Id); 1220 1221 -- If the master is declared locally, add the renaming declaration 1222 -- immediately after it, to prevent access-before-elaboration in the 1223 -- back-end. 1224 1225 if Present (Master_Decl) then 1226 Insert_After (Master_Decl, Ren_Decl); 1227 Analyze (Ren_Decl); 1228 1229 else 1230 Insert_Action (Related_Node, Ren_Decl); 1231 end if; 1232 1233 Set_Master_Id (Typ, Master_Id); 1234 end Build_Class_Wide_Master; 1235 1236 ---------------------------- 1237 -- Build_Contract_Wrapper -- 1238 ---------------------------- 1239 1240 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id) is 1241 Conc_Typ : constant Entity_Id := Scope (E); 1242 Loc : constant Source_Ptr := Sloc (E); 1243 1244 procedure Add_Discriminant_Renamings 1245 (Obj_Id : Entity_Id; 1246 Decls : List_Id); 1247 -- Add renaming declarations for all discriminants of concurrent type 1248 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which 1249 -- represents the concurrent object. 1250 1251 procedure Add_Matching_Formals 1252 (Formals : List_Id; 1253 Actuals : in out List_Id); 1254 -- Add formal parameters that match those of entry E to list Formals. 1255 -- The routine also adds matching actuals for the new formals to list 1256 -- Actuals. 1257 1258 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id); 1259 -- Relocate pragma Prag to list To. The routine creates a new list if 1260 -- To does not exist. 1261 1262 -------------------------------- 1263 -- Add_Discriminant_Renamings -- 1264 -------------------------------- 1265 1266 procedure Add_Discriminant_Renamings 1267 (Obj_Id : Entity_Id; 1268 Decls : List_Id) 1269 is 1270 Discr : Entity_Id; 1271 1272 begin 1273 -- Inspect the discriminants of the concurrent type and generate a 1274 -- renaming for each one. 1275 1276 if Has_Discriminants (Conc_Typ) then 1277 Discr := First_Discriminant (Conc_Typ); 1278 while Present (Discr) loop 1279 Prepend_To (Decls, 1280 Make_Object_Renaming_Declaration (Loc, 1281 Defining_Identifier => 1282 Make_Defining_Identifier (Loc, Chars (Discr)), 1283 Subtype_Mark => 1284 New_Occurrence_Of (Etype (Discr), Loc), 1285 Name => 1286 Make_Selected_Component (Loc, 1287 Prefix => New_Occurrence_Of (Obj_Id, Loc), 1288 Selector_Name => 1289 Make_Identifier (Loc, Chars (Discr))))); 1290 1291 Next_Discriminant (Discr); 1292 end loop; 1293 end if; 1294 end Add_Discriminant_Renamings; 1295 1296 -------------------------- 1297 -- Add_Matching_Formals -- 1298 -------------------------- 1299 1300 procedure Add_Matching_Formals 1301 (Formals : List_Id; 1302 Actuals : in out List_Id) 1303 is 1304 Formal : Entity_Id; 1305 New_Formal : Entity_Id; 1306 1307 begin 1308 -- Inspect the formal parameters of the entry and generate a new 1309 -- matching formal with the same name for the wrapper. A reference 1310 -- to the new formal becomes an actual in the entry call. 1311 1312 Formal := First_Formal (E); 1313 while Present (Formal) loop 1314 New_Formal := Make_Defining_Identifier (Loc, Chars (Formal)); 1315 Append_To (Formals, 1316 Make_Parameter_Specification (Loc, 1317 Defining_Identifier => New_Formal, 1318 In_Present => In_Present (Parent (Formal)), 1319 Out_Present => Out_Present (Parent (Formal)), 1320 Parameter_Type => 1321 New_Occurrence_Of (Etype (Formal), Loc))); 1322 1323 if No (Actuals) then 1324 Actuals := New_List; 1325 end if; 1326 1327 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); 1328 Next_Formal (Formal); 1329 end loop; 1330 end Add_Matching_Formals; 1331 1332 --------------------- 1333 -- Transfer_Pragma -- 1334 --------------------- 1335 1336 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id) is 1337 New_Prag : Node_Id; 1338 1339 begin 1340 if No (To) then 1341 To := New_List; 1342 end if; 1343 1344 New_Prag := Relocate_Node (Prag); 1345 1346 Set_Analyzed (New_Prag, False); 1347 Append (New_Prag, To); 1348 end Transfer_Pragma; 1349 1350 -- Local variables 1351 1352 Items : constant Node_Id := Contract (E); 1353 Actuals : List_Id := No_List; 1354 Call : Node_Id; 1355 Call_Nam : Node_Id; 1356 Decls : List_Id := No_List; 1357 Formals : List_Id; 1358 Has_Pragma : Boolean := False; 1359 Index_Id : Entity_Id; 1360 Obj_Id : Entity_Id; 1361 Prag : Node_Id; 1362 Wrapper_Id : Entity_Id; 1363 1364 -- Start of processing for Build_Contract_Wrapper 1365 1366 begin 1367 -- This routine generates a specialized wrapper for a protected or task 1368 -- entry [family] which implements precondition/postcondition semantics. 1369 -- Preconditions and case guards of contract cases are checked before 1370 -- the protected action or rendezvous takes place. Postconditions and 1371 -- consequences of contract cases are checked after the protected action 1372 -- or rendezvous takes place. The structure of the generated wrapper is 1373 -- as follows: 1374 1375 -- procedure Wrapper 1376 -- (Obj_Id : Conc_Typ; -- concurrent object 1377 -- [Index : Index_Typ;] -- index of entry family 1378 -- [Formal_1 : ...; -- parameters of original entry 1379 -- Formal_N : ...]) 1380 -- is 1381 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant 1382 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings 1383 1384 -- <precondition checks> 1385 -- <case guard checks> 1386 1387 -- procedure _Postconditions is 1388 -- begin 1389 -- <postcondition checks> 1390 -- <consequence checks> 1391 -- end _Postconditions; 1392 1393 -- begin 1394 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]); 1395 -- _Postconditions; 1396 -- end Wrapper; 1397 1398 -- Create the wrapper only when the entry has at least one executable 1399 -- contract item such as contract cases, precondition or postcondition. 1400 1401 if Present (Items) then 1402 1403 -- Inspect the list of pre/postconditions and transfer all available 1404 -- pragmas to the declarative list of the wrapper. 1405 1406 Prag := Pre_Post_Conditions (Items); 1407 while Present (Prag) loop 1408 if Nam_In (Pragma_Name_Unmapped (Prag), 1409 Name_Postcondition, Name_Precondition) 1410 and then Is_Checked (Prag) 1411 then 1412 Has_Pragma := True; 1413 Transfer_Pragma (Prag, To => Decls); 1414 end if; 1415 1416 Prag := Next_Pragma (Prag); 1417 end loop; 1418 1419 -- Inspect the list of test/contract cases and transfer only contract 1420 -- cases pragmas to the declarative part of the wrapper. 1421 1422 Prag := Contract_Test_Cases (Items); 1423 while Present (Prag) loop 1424 if Pragma_Name (Prag) = Name_Contract_Cases 1425 and then Is_Checked (Prag) 1426 then 1427 Has_Pragma := True; 1428 Transfer_Pragma (Prag, To => Decls); 1429 end if; 1430 1431 Prag := Next_Pragma (Prag); 1432 end loop; 1433 end if; 1434 1435 -- The entry lacks executable contract items and a wrapper is not needed 1436 1437 if not Has_Pragma then 1438 return; 1439 end if; 1440 1441 -- Create the profile of the wrapper. The first formal parameter is the 1442 -- concurrent object. 1443 1444 Obj_Id := 1445 Make_Defining_Identifier (Loc, 1446 Chars => New_External_Name (Chars (Conc_Typ), 'A')); 1447 1448 Formals := New_List ( 1449 Make_Parameter_Specification (Loc, 1450 Defining_Identifier => Obj_Id, 1451 Out_Present => True, 1452 In_Present => True, 1453 Parameter_Type => New_Occurrence_Of (Conc_Typ, Loc))); 1454 1455 -- Construct the call to the original entry. The call will be gradually 1456 -- augmented with an optional entry index and extra parameters. 1457 1458 Call_Nam := 1459 Make_Selected_Component (Loc, 1460 Prefix => New_Occurrence_Of (Obj_Id, Loc), 1461 Selector_Name => New_Occurrence_Of (E, Loc)); 1462 1463 -- When creating a wrapper for an entry family, the second formal is the 1464 -- entry index. 1465 1466 if Ekind (E) = E_Entry_Family then 1467 Index_Id := Make_Defining_Identifier (Loc, Name_I); 1468 1469 Append_To (Formals, 1470 Make_Parameter_Specification (Loc, 1471 Defining_Identifier => Index_Id, 1472 Parameter_Type => 1473 New_Occurrence_Of (Entry_Index_Type (E), Loc))); 1474 1475 -- The call to the original entry becomes an indexed component to 1476 -- accommodate the entry index. 1477 1478 Call_Nam := 1479 Make_Indexed_Component (Loc, 1480 Prefix => Call_Nam, 1481 Expressions => New_List (New_Occurrence_Of (Index_Id, Loc))); 1482 end if; 1483 1484 -- Add formal parameters to match those of the entry and build actuals 1485 -- for the entry call. 1486 1487 Add_Matching_Formals (Formals, Actuals); 1488 1489 Call := 1490 Make_Procedure_Call_Statement (Loc, 1491 Name => Call_Nam, 1492 Parameter_Associations => Actuals); 1493 1494 -- Add renaming declarations for the discriminants of the enclosing type 1495 -- as the various contract items may reference them. 1496 1497 Add_Discriminant_Renamings (Obj_Id, Decls); 1498 1499 Wrapper_Id := 1500 Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E')); 1501 Set_Contract_Wrapper (E, Wrapper_Id); 1502 Set_Is_Entry_Wrapper (Wrapper_Id); 1503 1504 -- The wrapper body is analyzed when the enclosing type is frozen 1505 1506 Append_Freeze_Action (Defining_Entity (Decl), 1507 Make_Subprogram_Body (Loc, 1508 Specification => 1509 Make_Procedure_Specification (Loc, 1510 Defining_Unit_Name => Wrapper_Id, 1511 Parameter_Specifications => Formals), 1512 Declarations => Decls, 1513 Handled_Statement_Sequence => 1514 Make_Handled_Sequence_Of_Statements (Loc, 1515 Statements => New_List (Call)))); 1516 end Build_Contract_Wrapper; 1517 1518 -------------------------------- 1519 -- Build_Corresponding_Record -- 1520 -------------------------------- 1521 1522 function Build_Corresponding_Record 1523 (N : Node_Id; 1524 Ctyp : Entity_Id; 1525 Loc : Source_Ptr) return Node_Id 1526 is 1527 Rec_Ent : constant Entity_Id := 1528 Make_Defining_Identifier 1529 (Loc, New_External_Name (Chars (Ctyp), 'V')); 1530 Disc : Entity_Id; 1531 Dlist : List_Id; 1532 New_Disc : Entity_Id; 1533 Cdecls : List_Id; 1534 1535 begin 1536 Set_Corresponding_Record_Type (Ctyp, Rec_Ent); 1537 Set_Ekind (Rec_Ent, E_Record_Type); 1538 Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp)); 1539 Set_Is_Concurrent_Record_Type (Rec_Ent, True); 1540 Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp); 1541 Set_Stored_Constraint (Rec_Ent, No_Elist); 1542 Cdecls := New_List; 1543 1544 -- Use discriminals to create list of discriminants for record, and 1545 -- create new discriminals for use in default expressions, etc. It is 1546 -- worth noting that a task discriminant gives rise to 5 entities; 1547 1548 -- a) The original discriminant. 1549 -- b) The discriminal for use in the task. 1550 -- c) The discriminant of the corresponding record. 1551 -- d) The discriminal for the init proc of the corresponding record. 1552 -- e) The local variable that renames the discriminant in the procedure 1553 -- for the task body. 1554 1555 -- In fact the discriminals b) are used in the renaming declarations 1556 -- for e). See details in einfo (Handling of Discriminants). 1557 1558 if Present (Discriminant_Specifications (N)) then 1559 Dlist := New_List; 1560 Disc := First_Discriminant (Ctyp); 1561 1562 while Present (Disc) loop 1563 New_Disc := CR_Discriminant (Disc); 1564 1565 Append_To (Dlist, 1566 Make_Discriminant_Specification (Loc, 1567 Defining_Identifier => New_Disc, 1568 Discriminant_Type => 1569 New_Occurrence_Of (Etype (Disc), Loc), 1570 Expression => 1571 New_Copy (Discriminant_Default_Value (Disc)))); 1572 1573 Next_Discriminant (Disc); 1574 end loop; 1575 1576 else 1577 Dlist := No_List; 1578 end if; 1579 1580 -- Now we can construct the record type declaration. Note that this 1581 -- record is "limited tagged". It is "limited" to reflect the underlying 1582 -- limitedness of the task or protected object that it represents, and 1583 -- ensuring for example that it is properly passed by reference. It is 1584 -- "tagged" to give support to dispatching calls through interfaces. We 1585 -- propagate here the list of interfaces covered by the concurrent type 1586 -- (Ada 2005: AI-345). 1587 1588 return 1589 Make_Full_Type_Declaration (Loc, 1590 Defining_Identifier => Rec_Ent, 1591 Discriminant_Specifications => Dlist, 1592 Type_Definition => 1593 Make_Record_Definition (Loc, 1594 Component_List => 1595 Make_Component_List (Loc, Component_Items => Cdecls), 1596 Tagged_Present => 1597 Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp), 1598 Interface_List => Interface_List (N), 1599 Limited_Present => True)); 1600 end Build_Corresponding_Record; 1601 1602 --------------------------------- 1603 -- Build_Dispatching_Tag_Check -- 1604 --------------------------------- 1605 1606 function Build_Dispatching_Tag_Check 1607 (K : Entity_Id; 1608 N : Node_Id) return Node_Id 1609 is 1610 Loc : constant Source_Ptr := Sloc (N); 1611 1612 begin 1613 return 1614 Make_Op_Or (Loc, 1615 Make_Op_Eq (Loc, 1616 Left_Opnd => 1617 New_Occurrence_Of (K, Loc), 1618 Right_Opnd => 1619 New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc)), 1620 1621 Make_Op_Eq (Loc, 1622 Left_Opnd => 1623 New_Occurrence_Of (K, Loc), 1624 Right_Opnd => 1625 New_Occurrence_Of (RTE (RE_TK_Tagged), Loc))); 1626 end Build_Dispatching_Tag_Check; 1627 1628 ---------------------------------- 1629 -- Build_Entry_Count_Expression -- 1630 ---------------------------------- 1631 1632 function Build_Entry_Count_Expression 1633 (Concurrent_Type : Node_Id; 1634 Component_List : List_Id; 1635 Loc : Source_Ptr) return Node_Id 1636 is 1637 Eindx : Nat; 1638 Ent : Entity_Id; 1639 Ecount : Node_Id; 1640 Comp : Node_Id; 1641 Lo : Node_Id; 1642 Hi : Node_Id; 1643 Typ : Entity_Id; 1644 Large : Boolean; 1645 1646 begin 1647 -- Count number of non-family entries 1648 1649 Eindx := 0; 1650 Ent := First_Entity (Concurrent_Type); 1651 while Present (Ent) loop 1652 if Ekind (Ent) = E_Entry then 1653 Eindx := Eindx + 1; 1654 end if; 1655 1656 Next_Entity (Ent); 1657 end loop; 1658 1659 Ecount := Make_Integer_Literal (Loc, Eindx); 1660 1661 -- Loop through entry families building the addition nodes 1662 1663 Ent := First_Entity (Concurrent_Type); 1664 Comp := First (Component_List); 1665 while Present (Ent) loop 1666 if Ekind (Ent) = E_Entry_Family then 1667 while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop 1668 Next (Comp); 1669 end loop; 1670 1671 Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); 1672 Hi := Type_High_Bound (Typ); 1673 Lo := Type_Low_Bound (Typ); 1674 Large := Is_Potentially_Large_Family 1675 (Base_Type (Typ), Concurrent_Type, Lo, Hi); 1676 Ecount := 1677 Make_Op_Add (Loc, 1678 Left_Opnd => Ecount, 1679 Right_Opnd => 1680 Family_Size (Loc, Hi, Lo, Concurrent_Type, Large)); 1681 end if; 1682 1683 Next_Entity (Ent); 1684 end loop; 1685 1686 return Ecount; 1687 end Build_Entry_Count_Expression; 1688 1689 --------------------------- 1690 -- Build_Parameter_Block -- 1691 --------------------------- 1692 1693 function Build_Parameter_Block 1694 (Loc : Source_Ptr; 1695 Actuals : List_Id; 1696 Formals : List_Id; 1697 Decls : List_Id) return Entity_Id 1698 is 1699 Actual : Entity_Id; 1700 Comp_Nam : Node_Id; 1701 Comps : List_Id; 1702 Formal : Entity_Id; 1703 Has_Comp : Boolean := False; 1704 Rec_Nam : Node_Id; 1705 1706 begin 1707 Actual := First (Actuals); 1708 Comps := New_List; 1709 Formal := Defining_Identifier (First (Formals)); 1710 1711 while Present (Actual) loop 1712 if not Is_Controlling_Actual (Actual) then 1713 1714 -- Generate: 1715 -- type Ann is access all <actual-type> 1716 1717 Comp_Nam := Make_Temporary (Loc, 'A'); 1718 Set_Is_Param_Block_Component_Type (Comp_Nam); 1719 1720 Append_To (Decls, 1721 Make_Full_Type_Declaration (Loc, 1722 Defining_Identifier => Comp_Nam, 1723 Type_Definition => 1724 Make_Access_To_Object_Definition (Loc, 1725 All_Present => True, 1726 Constant_Present => Ekind (Formal) = E_In_Parameter, 1727 Subtype_Indication => 1728 New_Occurrence_Of (Etype (Actual), Loc)))); 1729 1730 -- Generate: 1731 -- Param : Ann; 1732 1733 Append_To (Comps, 1734 Make_Component_Declaration (Loc, 1735 Defining_Identifier => 1736 Make_Defining_Identifier (Loc, Chars (Formal)), 1737 Component_Definition => 1738 Make_Component_Definition (Loc, 1739 Aliased_Present => 1740 False, 1741 Subtype_Indication => 1742 New_Occurrence_Of (Comp_Nam, Loc)))); 1743 1744 Has_Comp := True; 1745 end if; 1746 1747 Next_Actual (Actual); 1748 Next_Formal_With_Extras (Formal); 1749 end loop; 1750 1751 Rec_Nam := Make_Temporary (Loc, 'P'); 1752 1753 if Has_Comp then 1754 1755 -- Generate: 1756 -- type Pnn is record 1757 -- Param1 : Ann1; 1758 -- ... 1759 -- ParamN : AnnN; 1760 1761 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are 1762 -- the original parameter names and Ann1 .. AnnN are the access to 1763 -- actual types. 1764 1765 Append_To (Decls, 1766 Make_Full_Type_Declaration (Loc, 1767 Defining_Identifier => 1768 Rec_Nam, 1769 Type_Definition => 1770 Make_Record_Definition (Loc, 1771 Component_List => 1772 Make_Component_List (Loc, Comps)))); 1773 else 1774 -- Generate: 1775 -- type Pnn is null record; 1776 1777 Append_To (Decls, 1778 Make_Full_Type_Declaration (Loc, 1779 Defining_Identifier => 1780 Rec_Nam, 1781 Type_Definition => 1782 Make_Record_Definition (Loc, 1783 Null_Present => True, 1784 Component_List => Empty))); 1785 end if; 1786 1787 return Rec_Nam; 1788 end Build_Parameter_Block; 1789 1790 -------------------------------------- 1791 -- Build_Renamed_Formal_Declaration -- 1792 -------------------------------------- 1793 1794 function Build_Renamed_Formal_Declaration 1795 (New_F : Entity_Id; 1796 Formal : Entity_Id; 1797 Comp : Entity_Id; 1798 Renamed_Formal : Node_Id) return Node_Id 1799 is 1800 Loc : constant Source_Ptr := Sloc (New_F); 1801 Decl : Node_Id; 1802 1803 begin 1804 -- If the formal is a tagged incomplete type, it is already passed 1805 -- by reference, so it is sufficient to rename the pointer component 1806 -- that corresponds to the actual. Otherwise we need to dereference 1807 -- the pointer component to obtain the actual. 1808 1809 if Is_Incomplete_Type (Etype (Formal)) 1810 and then Is_Tagged_Type (Etype (Formal)) 1811 then 1812 Decl := 1813 Make_Object_Renaming_Declaration (Loc, 1814 Defining_Identifier => New_F, 1815 Subtype_Mark => New_Occurrence_Of (Etype (Comp), Loc), 1816 Name => Renamed_Formal); 1817 1818 else 1819 Decl := 1820 Make_Object_Renaming_Declaration (Loc, 1821 Defining_Identifier => New_F, 1822 Subtype_Mark => New_Occurrence_Of (Etype (Formal), Loc), 1823 Name => 1824 Make_Explicit_Dereference (Loc, Renamed_Formal)); 1825 end if; 1826 1827 return Decl; 1828 end Build_Renamed_Formal_Declaration; 1829 1830 -------------------------- 1831 -- Build_Wrapper_Bodies -- 1832 -------------------------- 1833 1834 procedure Build_Wrapper_Bodies 1835 (Loc : Source_Ptr; 1836 Typ : Entity_Id; 1837 N : Node_Id) 1838 is 1839 Rec_Typ : Entity_Id; 1840 1841 function Build_Wrapper_Body 1842 (Loc : Source_Ptr; 1843 Subp_Id : Entity_Id; 1844 Obj_Typ : Entity_Id; 1845 Formals : List_Id) return Node_Id; 1846 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation 1847 -- associated with a protected or task type. Subp_Id is the subprogram 1848 -- name which will be wrapped. Obj_Typ is the type of the new formal 1849 -- parameter which handles dispatching and object notation. Formals are 1850 -- the original formals of Subp_Id which will be explicitly replicated. 1851 1852 ------------------------ 1853 -- Build_Wrapper_Body -- 1854 ------------------------ 1855 1856 function Build_Wrapper_Body 1857 (Loc : Source_Ptr; 1858 Subp_Id : Entity_Id; 1859 Obj_Typ : Entity_Id; 1860 Formals : List_Id) return Node_Id 1861 is 1862 Body_Spec : Node_Id; 1863 1864 begin 1865 Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals); 1866 1867 -- The subprogram is not overriding or is not a primitive declared 1868 -- between two views. 1869 1870 if No (Body_Spec) then 1871 return Empty; 1872 end if; 1873 1874 declare 1875 Actuals : List_Id := No_List; 1876 Conv_Id : Node_Id; 1877 First_Form : Node_Id; 1878 Formal : Node_Id; 1879 Nam : Node_Id; 1880 1881 begin 1882 -- Map formals to actuals. Use the list built for the wrapper 1883 -- spec, skipping the object notation parameter. 1884 1885 First_Form := First (Parameter_Specifications (Body_Spec)); 1886 1887 Formal := First_Form; 1888 Next (Formal); 1889 1890 if Present (Formal) then 1891 Actuals := New_List; 1892 while Present (Formal) loop 1893 Append_To (Actuals, 1894 Make_Identifier (Loc, 1895 Chars => Chars (Defining_Identifier (Formal)))); 1896 Next (Formal); 1897 end loop; 1898 end if; 1899 1900 -- Special processing for primitives declared between a private 1901 -- type and its completion: the wrapper needs a properly typed 1902 -- parameter if the wrapped operation has a controlling first 1903 -- parameter. Note that this might not be the case for a function 1904 -- with a controlling result. 1905 1906 if Is_Private_Primitive_Subprogram (Subp_Id) then 1907 if No (Actuals) then 1908 Actuals := New_List; 1909 end if; 1910 1911 if Is_Controlling_Formal (First_Formal (Subp_Id)) then 1912 Prepend_To (Actuals, 1913 Unchecked_Convert_To 1914 (Corresponding_Concurrent_Type (Obj_Typ), 1915 Make_Identifier (Loc, Name_uO))); 1916 1917 else 1918 Prepend_To (Actuals, 1919 Make_Identifier (Loc, 1920 Chars => Chars (Defining_Identifier (First_Form)))); 1921 end if; 1922 1923 Nam := New_Occurrence_Of (Subp_Id, Loc); 1924 else 1925 -- An access-to-variable object parameter requires an explicit 1926 -- dereference in the unchecked conversion. This case occurs 1927 -- when a protected entry wrapper must override an interface 1928 -- level procedure with interface access as first parameter. 1929 1930 -- O.all.Subp_Id (Formal_1, ..., Formal_N) 1931 1932 if Nkind (Parameter_Type (First_Form)) = 1933 N_Access_Definition 1934 then 1935 Conv_Id := 1936 Make_Explicit_Dereference (Loc, 1937 Prefix => Make_Identifier (Loc, Name_uO)); 1938 else 1939 Conv_Id := Make_Identifier (Loc, Name_uO); 1940 end if; 1941 1942 Nam := 1943 Make_Selected_Component (Loc, 1944 Prefix => 1945 Unchecked_Convert_To 1946 (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id), 1947 Selector_Name => New_Occurrence_Of (Subp_Id, Loc)); 1948 end if; 1949 1950 -- Create the subprogram body. For a function, the call to the 1951 -- actual subprogram has to be converted to the corresponding 1952 -- record if it is a controlling result. 1953 1954 if Ekind (Subp_Id) = E_Function then 1955 declare 1956 Res : Node_Id; 1957 1958 begin 1959 Res := 1960 Make_Function_Call (Loc, 1961 Name => Nam, 1962 Parameter_Associations => Actuals); 1963 1964 if Has_Controlling_Result (Subp_Id) then 1965 Res := 1966 Unchecked_Convert_To 1967 (Corresponding_Record_Type (Etype (Subp_Id)), Res); 1968 end if; 1969 1970 return 1971 Make_Subprogram_Body (Loc, 1972 Specification => Body_Spec, 1973 Declarations => Empty_List, 1974 Handled_Statement_Sequence => 1975 Make_Handled_Sequence_Of_Statements (Loc, 1976 Statements => New_List ( 1977 Make_Simple_Return_Statement (Loc, Res)))); 1978 end; 1979 1980 else 1981 return 1982 Make_Subprogram_Body (Loc, 1983 Specification => Body_Spec, 1984 Declarations => Empty_List, 1985 Handled_Statement_Sequence => 1986 Make_Handled_Sequence_Of_Statements (Loc, 1987 Statements => New_List ( 1988 Make_Procedure_Call_Statement (Loc, 1989 Name => Nam, 1990 Parameter_Associations => Actuals)))); 1991 end if; 1992 end; 1993 end Build_Wrapper_Body; 1994 1995 -- Start of processing for Build_Wrapper_Bodies 1996 1997 begin 1998 if Is_Concurrent_Type (Typ) then 1999 Rec_Typ := Corresponding_Record_Type (Typ); 2000 else 2001 Rec_Typ := Typ; 2002 end if; 2003 2004 -- Generate wrapper bodies for a concurrent type which implements an 2005 -- interface. 2006 2007 if Present (Interfaces (Rec_Typ)) then 2008 declare 2009 Insert_Nod : Node_Id; 2010 Prim : Entity_Id; 2011 Prim_Elmt : Elmt_Id; 2012 Prim_Decl : Node_Id; 2013 Subp : Entity_Id; 2014 Wrap_Body : Node_Id; 2015 Wrap_Id : Entity_Id; 2016 2017 begin 2018 Insert_Nod := N; 2019 2020 -- Examine all primitive operations of the corresponding record 2021 -- type, looking for wrapper specs. Generate bodies in order to 2022 -- complete them. 2023 2024 Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ)); 2025 while Present (Prim_Elmt) loop 2026 Prim := Node (Prim_Elmt); 2027 2028 if (Ekind (Prim) = E_Function 2029 or else Ekind (Prim) = E_Procedure) 2030 and then Is_Primitive_Wrapper (Prim) 2031 then 2032 Subp := Wrapped_Entity (Prim); 2033 Prim_Decl := Parent (Parent (Prim)); 2034 2035 Wrap_Body := 2036 Build_Wrapper_Body (Loc, 2037 Subp_Id => Subp, 2038 Obj_Typ => Rec_Typ, 2039 Formals => Parameter_Specifications (Parent (Subp))); 2040 Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body)); 2041 2042 Set_Corresponding_Spec (Wrap_Body, Prim); 2043 Set_Corresponding_Body (Prim_Decl, Wrap_Id); 2044 2045 Insert_After (Insert_Nod, Wrap_Body); 2046 Insert_Nod := Wrap_Body; 2047 2048 Analyze (Wrap_Body); 2049 end if; 2050 2051 Next_Elmt (Prim_Elmt); 2052 end loop; 2053 end; 2054 end if; 2055 end Build_Wrapper_Bodies; 2056 2057 ------------------------ 2058 -- Build_Wrapper_Spec -- 2059 ------------------------ 2060 2061 function Build_Wrapper_Spec 2062 (Subp_Id : Entity_Id; 2063 Obj_Typ : Entity_Id; 2064 Formals : List_Id) return Node_Id 2065 is 2066 function Overriding_Possible 2067 (Iface_Op : Entity_Id; 2068 Wrapper : Entity_Id) return Boolean; 2069 -- Determine whether a primitive operation can be overridden by Wrapper. 2070 -- Iface_Op is the candidate primitive operation of an interface type, 2071 -- Wrapper is the generated entry wrapper. 2072 2073 function Replicate_Formals 2074 (Loc : Source_Ptr; 2075 Formals : List_Id) return List_Id; 2076 -- An explicit parameter replication is required due to the Is_Entry_ 2077 -- Formal flag being set for all the formals of an entry. The explicit 2078 -- replication removes the flag that would otherwise cause a different 2079 -- path of analysis. 2080 2081 ------------------------- 2082 -- Overriding_Possible -- 2083 ------------------------- 2084 2085 function Overriding_Possible 2086 (Iface_Op : Entity_Id; 2087 Wrapper : Entity_Id) return Boolean 2088 is 2089 Iface_Op_Spec : constant Node_Id := Parent (Iface_Op); 2090 Wrapper_Spec : constant Node_Id := Parent (Wrapper); 2091 2092 function Type_Conformant_Parameters 2093 (Iface_Op_Params : List_Id; 2094 Wrapper_Params : List_Id) return Boolean; 2095 -- Determine whether the parameters of the generated entry wrapper 2096 -- and those of a primitive operation are type conformant. During 2097 -- this check, the first parameter of the primitive operation is 2098 -- skipped if it is a controlling argument: protected functions 2099 -- may have a controlling result. 2100 2101 -------------------------------- 2102 -- Type_Conformant_Parameters -- 2103 -------------------------------- 2104 2105 function Type_Conformant_Parameters 2106 (Iface_Op_Params : List_Id; 2107 Wrapper_Params : List_Id) return Boolean 2108 is 2109 Iface_Op_Param : Node_Id; 2110 Iface_Op_Typ : Entity_Id; 2111 Wrapper_Param : Node_Id; 2112 Wrapper_Typ : Entity_Id; 2113 2114 begin 2115 -- Skip the first (controlling) parameter of primitive operation 2116 2117 Iface_Op_Param := First (Iface_Op_Params); 2118 2119 if Present (First_Formal (Iface_Op)) 2120 and then Is_Controlling_Formal (First_Formal (Iface_Op)) 2121 then 2122 Iface_Op_Param := Next (Iface_Op_Param); 2123 end if; 2124 2125 Wrapper_Param := First (Wrapper_Params); 2126 while Present (Iface_Op_Param) 2127 and then Present (Wrapper_Param) 2128 loop 2129 Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param); 2130 Wrapper_Typ := Find_Parameter_Type (Wrapper_Param); 2131 2132 -- The two parameters must be mode conformant 2133 2134 if not Conforming_Types 2135 (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant) 2136 then 2137 return False; 2138 end if; 2139 2140 Next (Iface_Op_Param); 2141 Next (Wrapper_Param); 2142 end loop; 2143 2144 -- One of the lists is longer than the other 2145 2146 if Present (Iface_Op_Param) or else Present (Wrapper_Param) then 2147 return False; 2148 end if; 2149 2150 return True; 2151 end Type_Conformant_Parameters; 2152 2153 -- Start of processing for Overriding_Possible 2154 2155 begin 2156 if Chars (Iface_Op) /= Chars (Wrapper) then 2157 return False; 2158 end if; 2159 2160 -- If an inherited subprogram is implemented by a protected procedure 2161 -- or an entry, then the first parameter of the inherited subprogram 2162 -- must be of mode OUT or IN OUT, or access-to-variable parameter. 2163 2164 if Ekind (Iface_Op) = E_Procedure 2165 and then Present (Parameter_Specifications (Iface_Op_Spec)) 2166 then 2167 declare 2168 Obj_Param : constant Node_Id := 2169 First (Parameter_Specifications (Iface_Op_Spec)); 2170 begin 2171 if not Out_Present (Obj_Param) 2172 and then Nkind (Parameter_Type (Obj_Param)) /= 2173 N_Access_Definition 2174 then 2175 return False; 2176 end if; 2177 end; 2178 end if; 2179 2180 return 2181 Type_Conformant_Parameters 2182 (Parameter_Specifications (Iface_Op_Spec), 2183 Parameter_Specifications (Wrapper_Spec)); 2184 end Overriding_Possible; 2185 2186 ----------------------- 2187 -- Replicate_Formals -- 2188 ----------------------- 2189 2190 function Replicate_Formals 2191 (Loc : Source_Ptr; 2192 Formals : List_Id) return List_Id 2193 is 2194 New_Formals : constant List_Id := New_List; 2195 Formal : Node_Id; 2196 Param_Type : Node_Id; 2197 2198 begin 2199 Formal := First (Formals); 2200 2201 -- Skip the object parameter when dealing with primitives declared 2202 -- between two views. 2203 2204 if Is_Private_Primitive_Subprogram (Subp_Id) 2205 and then not Has_Controlling_Result (Subp_Id) 2206 then 2207 Formal := Next (Formal); 2208 end if; 2209 2210 while Present (Formal) loop 2211 2212 -- Create an explicit copy of the entry parameter 2213 2214 -- When creating the wrapper subprogram for a primitive operation 2215 -- of a protected interface we must construct an equivalent 2216 -- signature to that of the overriding operation. For regular 2217 -- parameters we can just use the type of the formal, but for 2218 -- access to subprogram parameters we need to reanalyze the 2219 -- parameter type to create local entities for the signature of 2220 -- the subprogram type. Using the entities of the overriding 2221 -- subprogram will result in out-of-scope errors in the back-end. 2222 2223 if Nkind (Parameter_Type (Formal)) = N_Access_Definition then 2224 Param_Type := Copy_Separate_Tree (Parameter_Type (Formal)); 2225 else 2226 Param_Type := 2227 New_Occurrence_Of (Etype (Parameter_Type (Formal)), Loc); 2228 end if; 2229 2230 Append_To (New_Formals, 2231 Make_Parameter_Specification (Loc, 2232 Defining_Identifier => 2233 Make_Defining_Identifier (Loc, 2234 Chars => Chars (Defining_Identifier (Formal))), 2235 In_Present => In_Present (Formal), 2236 Out_Present => Out_Present (Formal), 2237 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 2238 Parameter_Type => Param_Type)); 2239 2240 Next (Formal); 2241 end loop; 2242 2243 return New_Formals; 2244 end Replicate_Formals; 2245 2246 -- Local variables 2247 2248 Loc : constant Source_Ptr := Sloc (Subp_Id); 2249 First_Param : Node_Id := Empty; 2250 Iface : Entity_Id; 2251 Iface_Elmt : Elmt_Id; 2252 Iface_Op : Entity_Id; 2253 Iface_Op_Elmt : Elmt_Id; 2254 Overridden_Subp : Entity_Id; 2255 2256 -- Start of processing for Build_Wrapper_Spec 2257 2258 begin 2259 -- No point in building wrappers for untagged concurrent types 2260 2261 pragma Assert (Is_Tagged_Type (Obj_Typ)); 2262 2263 -- Check if this subprogram has a profile that matches some interface 2264 -- primitive. 2265 2266 Check_Synchronized_Overriding (Subp_Id, Overridden_Subp); 2267 2268 if Present (Overridden_Subp) then 2269 First_Param := 2270 First (Parameter_Specifications (Parent (Overridden_Subp))); 2271 2272 -- An entry or a protected procedure can override a routine where the 2273 -- controlling formal is either IN OUT, OUT or is of access-to-variable 2274 -- type. Since the wrapper must have the exact same signature as that of 2275 -- the overridden subprogram, we try to find the overriding candidate 2276 -- and use its controlling formal. 2277 2278 -- Check every implemented interface 2279 2280 elsif Present (Interfaces (Obj_Typ)) then 2281 Iface_Elmt := First_Elmt (Interfaces (Obj_Typ)); 2282 Search : while Present (Iface_Elmt) loop 2283 Iface := Node (Iface_Elmt); 2284 2285 -- Check every interface primitive 2286 2287 if Present (Primitive_Operations (Iface)) then 2288 Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); 2289 while Present (Iface_Op_Elmt) loop 2290 Iface_Op := Node (Iface_Op_Elmt); 2291 2292 -- Ignore predefined primitives 2293 2294 if not Is_Predefined_Dispatching_Operation (Iface_Op) then 2295 Iface_Op := Ultimate_Alias (Iface_Op); 2296 2297 -- The current primitive operation can be overridden by 2298 -- the generated entry wrapper. 2299 2300 if Overriding_Possible (Iface_Op, Subp_Id) then 2301 First_Param := 2302 First (Parameter_Specifications (Parent (Iface_Op))); 2303 2304 exit Search; 2305 end if; 2306 end if; 2307 2308 Next_Elmt (Iface_Op_Elmt); 2309 end loop; 2310 end if; 2311 2312 Next_Elmt (Iface_Elmt); 2313 end loop Search; 2314 end if; 2315 2316 -- Do not generate the wrapper if no interface primitive is covered by 2317 -- the subprogram and it is not a primitive declared between two views 2318 -- (see Process_Full_View). 2319 2320 if No (First_Param) 2321 and then not Is_Private_Primitive_Subprogram (Subp_Id) 2322 then 2323 return Empty; 2324 end if; 2325 2326 declare 2327 Wrapper_Id : constant Entity_Id := 2328 Make_Defining_Identifier (Loc, Chars (Subp_Id)); 2329 New_Formals : List_Id; 2330 Obj_Param : Node_Id; 2331 Obj_Param_Typ : Entity_Id; 2332 2333 begin 2334 -- Minimum decoration is needed to catch the entity in 2335 -- Sem_Ch6.Override_Dispatching_Operation. 2336 2337 if Ekind (Subp_Id) = E_Function then 2338 Set_Ekind (Wrapper_Id, E_Function); 2339 else 2340 Set_Ekind (Wrapper_Id, E_Procedure); 2341 end if; 2342 2343 Set_Is_Primitive_Wrapper (Wrapper_Id); 2344 Set_Wrapped_Entity (Wrapper_Id, Subp_Id); 2345 Set_Is_Private_Primitive (Wrapper_Id, 2346 Is_Private_Primitive_Subprogram (Subp_Id)); 2347 2348 -- Process the formals 2349 2350 New_Formals := Replicate_Formals (Loc, Formals); 2351 2352 -- A function with a controlling result and no first controlling 2353 -- formal needs no additional parameter. 2354 2355 if Has_Controlling_Result (Subp_Id) 2356 and then 2357 (No (First_Formal (Subp_Id)) 2358 or else not Is_Controlling_Formal (First_Formal (Subp_Id))) 2359 then 2360 null; 2361 2362 -- Routine Subp_Id has been found to override an interface primitive. 2363 -- If the interface operation has an access parameter, create a copy 2364 -- of it, with the same null exclusion indicator if present. 2365 2366 elsif Present (First_Param) then 2367 if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then 2368 Obj_Param_Typ := 2369 Make_Access_Definition (Loc, 2370 Subtype_Mark => 2371 New_Occurrence_Of (Obj_Typ, Loc), 2372 Null_Exclusion_Present => 2373 Null_Exclusion_Present (Parameter_Type (First_Param)), 2374 Constant_Present => 2375 Constant_Present (Parameter_Type (First_Param))); 2376 else 2377 Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc); 2378 end if; 2379 2380 Obj_Param := 2381 Make_Parameter_Specification (Loc, 2382 Defining_Identifier => 2383 Make_Defining_Identifier (Loc, 2384 Chars => Name_uO), 2385 In_Present => In_Present (First_Param), 2386 Out_Present => Out_Present (First_Param), 2387 Parameter_Type => Obj_Param_Typ); 2388 2389 Prepend_To (New_Formals, Obj_Param); 2390 2391 -- If we are dealing with a primitive declared between two views, 2392 -- implemented by a synchronized operation, we need to create 2393 -- a default parameter. The mode of the parameter must match that 2394 -- of the primitive operation. 2395 2396 else 2397 pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id)); 2398 2399 Obj_Param := 2400 Make_Parameter_Specification (Loc, 2401 Defining_Identifier => 2402 Make_Defining_Identifier (Loc, Name_uO), 2403 In_Present => 2404 In_Present (Parent (First_Entity (Subp_Id))), 2405 Out_Present => Ekind (Subp_Id) /= E_Function, 2406 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); 2407 2408 Prepend_To (New_Formals, Obj_Param); 2409 end if; 2410 2411 -- Build the final spec. If it is a function with a controlling 2412 -- result, it is a primitive operation of the corresponding 2413 -- record type, so mark the spec accordingly. 2414 2415 if Ekind (Subp_Id) = E_Function then 2416 declare 2417 Res_Def : Node_Id; 2418 2419 begin 2420 if Has_Controlling_Result (Subp_Id) then 2421 Res_Def := 2422 New_Occurrence_Of 2423 (Corresponding_Record_Type (Etype (Subp_Id)), Loc); 2424 else 2425 Res_Def := New_Copy (Result_Definition (Parent (Subp_Id))); 2426 end if; 2427 2428 return 2429 Make_Function_Specification (Loc, 2430 Defining_Unit_Name => Wrapper_Id, 2431 Parameter_Specifications => New_Formals, 2432 Result_Definition => Res_Def); 2433 end; 2434 else 2435 return 2436 Make_Procedure_Specification (Loc, 2437 Defining_Unit_Name => Wrapper_Id, 2438 Parameter_Specifications => New_Formals); 2439 end if; 2440 end; 2441 end Build_Wrapper_Spec; 2442 2443 ------------------------- 2444 -- Build_Wrapper_Specs -- 2445 ------------------------- 2446 2447 procedure Build_Wrapper_Specs 2448 (Loc : Source_Ptr; 2449 Typ : Entity_Id; 2450 N : in out Node_Id) 2451 is 2452 Def : Node_Id; 2453 Rec_Typ : Entity_Id; 2454 procedure Scan_Declarations (L : List_Id); 2455 -- Common processing for visible and private declarations 2456 -- of a protected type. 2457 2458 procedure Scan_Declarations (L : List_Id) is 2459 Decl : Node_Id; 2460 Wrap_Decl : Node_Id; 2461 Wrap_Spec : Node_Id; 2462 2463 begin 2464 if No (L) then 2465 return; 2466 end if; 2467 2468 Decl := First (L); 2469 while Present (Decl) loop 2470 Wrap_Spec := Empty; 2471 2472 if Nkind (Decl) = N_Entry_Declaration 2473 and then Ekind (Defining_Identifier (Decl)) = E_Entry 2474 then 2475 Wrap_Spec := 2476 Build_Wrapper_Spec 2477 (Subp_Id => Defining_Identifier (Decl), 2478 Obj_Typ => Rec_Typ, 2479 Formals => Parameter_Specifications (Decl)); 2480 2481 elsif Nkind (Decl) = N_Subprogram_Declaration then 2482 Wrap_Spec := 2483 Build_Wrapper_Spec 2484 (Subp_Id => Defining_Unit_Name (Specification (Decl)), 2485 Obj_Typ => Rec_Typ, 2486 Formals => 2487 Parameter_Specifications (Specification (Decl))); 2488 end if; 2489 2490 if Present (Wrap_Spec) then 2491 Wrap_Decl := 2492 Make_Subprogram_Declaration (Loc, 2493 Specification => Wrap_Spec); 2494 2495 Insert_After (N, Wrap_Decl); 2496 N := Wrap_Decl; 2497 2498 Analyze (Wrap_Decl); 2499 end if; 2500 2501 Next (Decl); 2502 end loop; 2503 end Scan_Declarations; 2504 2505 -- start of processing for Build_Wrapper_Specs 2506 2507 begin 2508 if Is_Protected_Type (Typ) then 2509 Def := Protected_Definition (Parent (Typ)); 2510 else pragma Assert (Is_Task_Type (Typ)); 2511 Def := Task_Definition (Parent (Typ)); 2512 end if; 2513 2514 Rec_Typ := Corresponding_Record_Type (Typ); 2515 2516 -- Generate wrapper specs for a concurrent type which implements an 2517 -- interface. Operations in both the visible and private parts may 2518 -- implement progenitor operations. 2519 2520 if Present (Interfaces (Rec_Typ)) and then Present (Def) then 2521 Scan_Declarations (Visible_Declarations (Def)); 2522 Scan_Declarations (Private_Declarations (Def)); 2523 end if; 2524 end Build_Wrapper_Specs; 2525 2526 --------------------------- 2527 -- Build_Find_Body_Index -- 2528 --------------------------- 2529 2530 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is 2531 Loc : constant Source_Ptr := Sloc (Typ); 2532 Ent : Entity_Id; 2533 E_Typ : Entity_Id; 2534 Has_F : Boolean := False; 2535 Index : Nat; 2536 If_St : Node_Id := Empty; 2537 Lo : Node_Id; 2538 Hi : Node_Id; 2539 Decls : List_Id := New_List; 2540 Ret : Node_Id; 2541 Spec : Node_Id; 2542 Siz : Node_Id := Empty; 2543 2544 procedure Add_If_Clause (Expr : Node_Id); 2545 -- Add test for range of current entry 2546 2547 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 2548 -- If a bound of an entry is given by a discriminant, retrieve the 2549 -- actual value of the discriminant from the enclosing object. 2550 2551 ------------------- 2552 -- Add_If_Clause -- 2553 ------------------- 2554 2555 procedure Add_If_Clause (Expr : Node_Id) is 2556 Cond : Node_Id; 2557 Stats : constant List_Id := 2558 New_List ( 2559 Make_Simple_Return_Statement (Loc, 2560 Expression => Make_Integer_Literal (Loc, Index + 1))); 2561 2562 begin 2563 -- Index for current entry body 2564 2565 Index := Index + 1; 2566 2567 -- Compute total length of entry queues so far 2568 2569 if No (Siz) then 2570 Siz := Expr; 2571 else 2572 Siz := 2573 Make_Op_Add (Loc, 2574 Left_Opnd => Siz, 2575 Right_Opnd => Expr); 2576 end if; 2577 2578 Cond := 2579 Make_Op_Le (Loc, 2580 Left_Opnd => Make_Identifier (Loc, Name_uE), 2581 Right_Opnd => Siz); 2582 2583 -- Map entry queue indexes in the range of the current family 2584 -- into the current index, that designates the entry body. 2585 2586 if No (If_St) then 2587 If_St := 2588 Make_Implicit_If_Statement (Typ, 2589 Condition => Cond, 2590 Then_Statements => Stats, 2591 Elsif_Parts => New_List); 2592 Ret := If_St; 2593 2594 else 2595 Append_To (Elsif_Parts (If_St), 2596 Make_Elsif_Part (Loc, 2597 Condition => Cond, 2598 Then_Statements => Stats)); 2599 end if; 2600 end Add_If_Clause; 2601 2602 ------------------------------ 2603 -- Convert_Discriminant_Ref -- 2604 ------------------------------ 2605 2606 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 2607 B : Node_Id; 2608 2609 begin 2610 if Is_Entity_Name (Bound) 2611 and then Ekind (Entity (Bound)) = E_Discriminant 2612 then 2613 B := 2614 Make_Selected_Component (Loc, 2615 Prefix => 2616 Unchecked_Convert_To (Corresponding_Record_Type (Typ), 2617 Make_Explicit_Dereference (Loc, 2618 Make_Identifier (Loc, Name_uObject))), 2619 Selector_Name => Make_Identifier (Loc, Chars (Bound))); 2620 Set_Etype (B, Etype (Entity (Bound))); 2621 else 2622 B := New_Copy_Tree (Bound); 2623 end if; 2624 2625 return B; 2626 end Convert_Discriminant_Ref; 2627 2628 -- Start of processing for Build_Find_Body_Index 2629 2630 begin 2631 Spec := Build_Find_Body_Index_Spec (Typ); 2632 2633 Ent := First_Entity (Typ); 2634 while Present (Ent) loop 2635 if Ekind (Ent) = E_Entry_Family then 2636 Has_F := True; 2637 exit; 2638 end if; 2639 2640 Next_Entity (Ent); 2641 end loop; 2642 2643 if not Has_F then 2644 2645 -- If the protected type has no entry families, there is a one-one 2646 -- correspondence between entry queue and entry body. 2647 2648 Ret := 2649 Make_Simple_Return_Statement (Loc, 2650 Expression => Make_Identifier (Loc, Name_uE)); 2651 2652 else 2653 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate 2654 -- the following: 2655 2656 -- if E <= l1 then return 1; 2657 -- elsif E <= l1 + l2 then return 2; 2658 -- ... 2659 2660 Index := 0; 2661 Siz := Empty; 2662 Ent := First_Entity (Typ); 2663 2664 Add_Object_Pointer (Loc, Typ, Decls); 2665 2666 while Present (Ent) loop 2667 if Ekind (Ent) = E_Entry then 2668 Add_If_Clause (Make_Integer_Literal (Loc, 1)); 2669 2670 elsif Ekind (Ent) = E_Entry_Family then 2671 E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); 2672 Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); 2673 Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); 2674 Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False)); 2675 end if; 2676 2677 Next_Entity (Ent); 2678 end loop; 2679 2680 if Index = 1 then 2681 Decls := New_List; 2682 Ret := 2683 Make_Simple_Return_Statement (Loc, 2684 Expression => Make_Integer_Literal (Loc, 1)); 2685 2686 elsif Nkind (Ret) = N_If_Statement then 2687 2688 -- Ranges are in increasing order, so last one doesn't need guard 2689 2690 declare 2691 Nod : constant Node_Id := Last (Elsif_Parts (Ret)); 2692 begin 2693 Remove (Nod); 2694 Set_Else_Statements (Ret, Then_Statements (Nod)); 2695 end; 2696 end if; 2697 end if; 2698 2699 return 2700 Make_Subprogram_Body (Loc, 2701 Specification => Spec, 2702 Declarations => Decls, 2703 Handled_Statement_Sequence => 2704 Make_Handled_Sequence_Of_Statements (Loc, 2705 Statements => New_List (Ret))); 2706 end Build_Find_Body_Index; 2707 2708 -------------------------------- 2709 -- Build_Find_Body_Index_Spec -- 2710 -------------------------------- 2711 2712 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is 2713 Loc : constant Source_Ptr := Sloc (Typ); 2714 Id : constant Entity_Id := 2715 Make_Defining_Identifier (Loc, 2716 Chars => New_External_Name (Chars (Typ), 'F')); 2717 Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO); 2718 Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE); 2719 2720 begin 2721 return 2722 Make_Function_Specification (Loc, 2723 Defining_Unit_Name => Id, 2724 Parameter_Specifications => New_List ( 2725 Make_Parameter_Specification (Loc, 2726 Defining_Identifier => Parm1, 2727 Parameter_Type => 2728 New_Occurrence_Of (RTE (RE_Address), Loc)), 2729 2730 Make_Parameter_Specification (Loc, 2731 Defining_Identifier => Parm2, 2732 Parameter_Type => 2733 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), 2734 2735 Result_Definition => New_Occurrence_Of ( 2736 RTE (RE_Protected_Entry_Index), Loc)); 2737 end Build_Find_Body_Index_Spec; 2738 2739 ----------------------------------------------- 2740 -- Build_Lock_Free_Protected_Subprogram_Body -- 2741 ----------------------------------------------- 2742 2743 function Build_Lock_Free_Protected_Subprogram_Body 2744 (N : Node_Id; 2745 Prot_Typ : Node_Id; 2746 Unprot_Spec : Node_Id) return Node_Id 2747 is 2748 Actuals : constant List_Id := New_List; 2749 Loc : constant Source_Ptr := Sloc (N); 2750 Spec : constant Node_Id := Specification (N); 2751 Unprot_Id : constant Entity_Id := Defining_Unit_Name (Unprot_Spec); 2752 Formal : Node_Id; 2753 Prot_Spec : Node_Id; 2754 Stmt : Node_Id; 2755 2756 begin 2757 -- Create the protected version of the body 2758 2759 Prot_Spec := 2760 Build_Protected_Sub_Specification (N, Prot_Typ, Protected_Mode); 2761 2762 -- Build the actual parameters which appear in the call to the 2763 -- unprotected version of the body. 2764 2765 Formal := First (Parameter_Specifications (Prot_Spec)); 2766 while Present (Formal) loop 2767 Append_To (Actuals, 2768 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 2769 2770 Next (Formal); 2771 end loop; 2772 2773 -- Function case, generate: 2774 -- return <Unprot_Func_Call>; 2775 2776 if Nkind (Spec) = N_Function_Specification then 2777 Stmt := 2778 Make_Simple_Return_Statement (Loc, 2779 Expression => 2780 Make_Function_Call (Loc, 2781 Name => 2782 Make_Identifier (Loc, Chars (Unprot_Id)), 2783 Parameter_Associations => Actuals)); 2784 2785 -- Procedure case, call the unprotected version 2786 2787 else 2788 Stmt := 2789 Make_Procedure_Call_Statement (Loc, 2790 Name => 2791 Make_Identifier (Loc, Chars (Unprot_Id)), 2792 Parameter_Associations => Actuals); 2793 end if; 2794 2795 return 2796 Make_Subprogram_Body (Loc, 2797 Declarations => Empty_List, 2798 Specification => Prot_Spec, 2799 Handled_Statement_Sequence => 2800 Make_Handled_Sequence_Of_Statements (Loc, 2801 Statements => New_List (Stmt))); 2802 end Build_Lock_Free_Protected_Subprogram_Body; 2803 2804 ------------------------------------------------- 2805 -- Build_Lock_Free_Unprotected_Subprogram_Body -- 2806 ------------------------------------------------- 2807 2808 -- Procedures which meet the lock-free implementation requirements and 2809 -- reference a unique scalar component Comp are expanded in the following 2810 -- manner: 2811 2812 -- procedure P (...) is 2813 -- Expected_Comp : constant Comp_Type := 2814 -- Comp_Type 2815 -- (System.Atomic_Primitives.Lock_Free_Read_N 2816 -- (_Object.Comp'Address)); 2817 -- begin 2818 -- loop 2819 -- declare 2820 -- <original declarations before the object renaming declaration 2821 -- of Comp> 2822 -- 2823 -- Desired_Comp : Comp_Type := Expected_Comp; 2824 -- Comp : Comp_Type renames Desired_Comp; 2825 -- 2826 -- <original delarations after the object renaming declaration 2827 -- of Comp> 2828 -- 2829 -- begin 2830 -- <original statements> 2831 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N 2832 -- (_Object.Comp'Address, 2833 -- Interfaces.Unsigned_N (Expected_Comp), 2834 -- Interfaces.Unsigned_N (Desired_Comp)); 2835 -- end; 2836 -- end loop; 2837 -- end P; 2838 2839 -- Each return and raise statement of P is transformed into an atomic 2840 -- status check: 2841 2842 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 2843 -- (_Object.Comp'Address, 2844 -- Interfaces.Unsigned_N (Expected_Comp), 2845 -- Interfaces.Unsigned_N (Desired_Comp)); 2846 -- then 2847 -- <original statement> 2848 -- else 2849 -- goto L0; 2850 -- end if; 2851 2852 -- Functions which meet the lock-free implementation requirements and 2853 -- reference a unique scalar component Comp are expanded in the following 2854 -- manner: 2855 2856 -- function F (...) return ... is 2857 -- <original declarations before the object renaming declaration 2858 -- of Comp> 2859 -- 2860 -- Expected_Comp : constant Comp_Type := 2861 -- Comp_Type 2862 -- (System.Atomic_Primitives.Lock_Free_Read_N 2863 -- (_Object.Comp'Address)); 2864 -- Comp : Comp_Type renames Expected_Comp; 2865 -- 2866 -- <original delarations after the object renaming declaration of 2867 -- Comp> 2868 -- 2869 -- begin 2870 -- <original statements> 2871 -- end F; 2872 2873 function Build_Lock_Free_Unprotected_Subprogram_Body 2874 (N : Node_Id; 2875 Prot_Typ : Node_Id) return Node_Id 2876 is 2877 function Referenced_Component (N : Node_Id) return Entity_Id; 2878 -- Subprograms which meet the lock-free implementation criteria are 2879 -- allowed to reference only one unique component. Return the prival 2880 -- of the said component. 2881 2882 -------------------------- 2883 -- Referenced_Component -- 2884 -------------------------- 2885 2886 function Referenced_Component (N : Node_Id) return Entity_Id is 2887 Comp : Entity_Id; 2888 Decl : Node_Id; 2889 Source_Comp : Entity_Id := Empty; 2890 2891 begin 2892 -- Find the unique source component which N references in its 2893 -- statements. 2894 2895 for Index in 1 .. Lock_Free_Subprogram_Table.Last loop 2896 declare 2897 Element : Lock_Free_Subprogram renames 2898 Lock_Free_Subprogram_Table.Table (Index); 2899 begin 2900 if Element.Sub_Body = N then 2901 Source_Comp := Element.Comp_Id; 2902 exit; 2903 end if; 2904 end; 2905 end loop; 2906 2907 if No (Source_Comp) then 2908 return Empty; 2909 end if; 2910 2911 -- Find the prival which corresponds to the source component within 2912 -- the declarations of N. 2913 2914 Decl := First (Declarations (N)); 2915 while Present (Decl) loop 2916 2917 -- Privals appear as object renamings 2918 2919 if Nkind (Decl) = N_Object_Renaming_Declaration then 2920 Comp := Defining_Identifier (Decl); 2921 2922 if Present (Prival_Link (Comp)) 2923 and then Prival_Link (Comp) = Source_Comp 2924 then 2925 return Comp; 2926 end if; 2927 end if; 2928 2929 Next (Decl); 2930 end loop; 2931 2932 return Empty; 2933 end Referenced_Component; 2934 2935 -- Local variables 2936 2937 Comp : constant Entity_Id := Referenced_Component (N); 2938 Loc : constant Source_Ptr := Sloc (N); 2939 Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N); 2940 Decls : List_Id := Declarations (N); 2941 2942 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body 2943 2944 begin 2945 -- Add renamings for the protection object, discriminals, privals, and 2946 -- the entry index constant for use by debugger. 2947 2948 Debug_Private_Data_Declarations (Decls); 2949 2950 -- Perform the lock-free expansion when the subprogram references a 2951 -- protected component. 2952 2953 if Present (Comp) then 2954 Protected_Component_Ref : declare 2955 Comp_Decl : constant Node_Id := Parent (Comp); 2956 Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl); 2957 Comp_Type : constant Entity_Id := Etype (Comp); 2958 2959 Is_Procedure : constant Boolean := 2960 Ekind (Corresponding_Spec (N)) = E_Procedure; 2961 -- Indicates if N is a protected procedure body 2962 2963 Block_Decls : List_Id := No_List; 2964 Try_Write : Entity_Id; 2965 Desired_Comp : Entity_Id; 2966 Decl : Node_Id; 2967 Label : Node_Id; 2968 Label_Id : Entity_Id := Empty; 2969 Read : Entity_Id; 2970 Expected_Comp : Entity_Id; 2971 Stmt : Node_Id; 2972 Stmts : List_Id := 2973 New_Copy_List (Statements (Hand_Stmt_Seq)); 2974 Typ_Size : Int; 2975 Unsigned : Entity_Id; 2976 2977 function Process_Node (N : Node_Id) return Traverse_Result; 2978 -- Transform a single node if it is a return statement, a raise 2979 -- statement or a reference to Comp. 2980 2981 procedure Process_Stmts (Stmts : List_Id); 2982 -- Given a statement sequence Stmts, wrap any return or raise 2983 -- statements in the following manner: 2984 -- 2985 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 2986 -- (_Object.Comp'Address, 2987 -- Interfaces.Unsigned_N (Expected_Comp), 2988 -- Interfaces.Unsigned_N (Desired_Comp)) 2989 -- then 2990 -- <Stmt>; 2991 -- else 2992 -- goto L0; 2993 -- end if; 2994 2995 ------------------ 2996 -- Process_Node -- 2997 ------------------ 2998 2999 function Process_Node (N : Node_Id) return Traverse_Result is 3000 3001 procedure Wrap_Statement (Stmt : Node_Id); 3002 -- Wrap an arbitrary statement inside an if statement where the 3003 -- condition does an atomic check on the state of the object. 3004 3005 -------------------- 3006 -- Wrap_Statement -- 3007 -------------------- 3008 3009 procedure Wrap_Statement (Stmt : Node_Id) is 3010 begin 3011 -- The first time through, create the declaration of a label 3012 -- which is used to skip the remainder of source statements 3013 -- if the state of the object has changed. 3014 3015 if No (Label_Id) then 3016 Label_Id := 3017 Make_Identifier (Loc, New_External_Name ('L', 0)); 3018 Set_Entity (Label_Id, 3019 Make_Defining_Identifier (Loc, Chars (Label_Id))); 3020 end if; 3021 3022 -- Generate: 3023 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3024 -- (_Object.Comp'Address, 3025 -- Interfaces.Unsigned_N (Expected_Comp), 3026 -- Interfaces.Unsigned_N (Desired_Comp)) 3027 -- then 3028 -- <Stmt>; 3029 -- else 3030 -- goto L0; 3031 -- end if; 3032 3033 Rewrite (Stmt, 3034 Make_Implicit_If_Statement (N, 3035 Condition => 3036 Make_Function_Call (Loc, 3037 Name => 3038 New_Occurrence_Of (Try_Write, Loc), 3039 Parameter_Associations => New_List ( 3040 Make_Attribute_Reference (Loc, 3041 Prefix => Relocate_Node (Comp_Sel_Nam), 3042 Attribute_Name => Name_Address), 3043 3044 Unchecked_Convert_To (Unsigned, 3045 New_Occurrence_Of (Expected_Comp, Loc)), 3046 3047 Unchecked_Convert_To (Unsigned, 3048 New_Occurrence_Of (Desired_Comp, Loc)))), 3049 3050 Then_Statements => New_List (Relocate_Node (Stmt)), 3051 3052 Else_Statements => New_List ( 3053 Make_Goto_Statement (Loc, 3054 Name => 3055 New_Occurrence_Of (Entity (Label_Id), Loc))))); 3056 end Wrap_Statement; 3057 3058 -- Start of processing for Process_Node 3059 3060 begin 3061 -- Wrap each return and raise statement that appear inside a 3062 -- procedure. Skip the last return statement which is added by 3063 -- default since it is transformed into an exit statement. 3064 3065 if Is_Procedure 3066 and then ((Nkind (N) = N_Simple_Return_Statement 3067 and then N /= Last (Stmts)) 3068 or else Nkind (N) = N_Extended_Return_Statement 3069 or else (Nkind_In (N, N_Raise_Constraint_Error, 3070 N_Raise_Program_Error, 3071 N_Raise_Statement, 3072 N_Raise_Storage_Error) 3073 and then Comes_From_Source (N))) 3074 then 3075 Wrap_Statement (N); 3076 return Skip; 3077 end if; 3078 3079 -- Force reanalysis 3080 3081 Set_Analyzed (N, False); 3082 3083 return OK; 3084 end Process_Node; 3085 3086 procedure Process_Nodes is new Traverse_Proc (Process_Node); 3087 3088 ------------------- 3089 -- Process_Stmts -- 3090 ------------------- 3091 3092 procedure Process_Stmts (Stmts : List_Id) is 3093 Stmt : Node_Id; 3094 begin 3095 Stmt := First (Stmts); 3096 while Present (Stmt) loop 3097 Process_Nodes (Stmt); 3098 Next (Stmt); 3099 end loop; 3100 end Process_Stmts; 3101 3102 -- Start of processing for Protected_Component_Ref 3103 3104 begin 3105 -- Get the type size 3106 3107 if Known_Static_Esize (Comp_Type) then 3108 Typ_Size := UI_To_Int (Esize (Comp_Type)); 3109 3110 -- If the Esize (Object_Size) is unknown at compile time, look at 3111 -- the RM_Size (Value_Size) since it may have been set by an 3112 -- explicit representation clause. 3113 3114 elsif Known_Static_RM_Size (Comp_Type) then 3115 Typ_Size := UI_To_Int (RM_Size (Comp_Type)); 3116 3117 -- Should not happen since this has already been checked in 3118 -- Allows_Lock_Free_Implementation (see Sem_Ch9). 3119 3120 else 3121 raise Program_Error; 3122 end if; 3123 3124 -- Retrieve all relevant atomic routines and types 3125 3126 case Typ_Size is 3127 when 8 => 3128 Try_Write := RTE (RE_Lock_Free_Try_Write_8); 3129 Read := RTE (RE_Lock_Free_Read_8); 3130 Unsigned := RTE (RE_Uint8); 3131 3132 when 16 => 3133 Try_Write := RTE (RE_Lock_Free_Try_Write_16); 3134 Read := RTE (RE_Lock_Free_Read_16); 3135 Unsigned := RTE (RE_Uint16); 3136 3137 when 32 => 3138 Try_Write := RTE (RE_Lock_Free_Try_Write_32); 3139 Read := RTE (RE_Lock_Free_Read_32); 3140 Unsigned := RTE (RE_Uint32); 3141 3142 when 64 => 3143 Try_Write := RTE (RE_Lock_Free_Try_Write_64); 3144 Read := RTE (RE_Lock_Free_Read_64); 3145 Unsigned := RTE (RE_Uint64); 3146 3147 when others => 3148 raise Program_Error; 3149 end case; 3150 3151 -- Generate: 3152 -- Expected_Comp : constant Comp_Type := 3153 -- Comp_Type 3154 -- (System.Atomic_Primitives.Lock_Free_Read_N 3155 -- (_Object.Comp'Address)); 3156 3157 Expected_Comp := 3158 Make_Defining_Identifier (Loc, 3159 New_External_Name (Chars (Comp), Suffix => "_saved")); 3160 3161 Decl := 3162 Make_Object_Declaration (Loc, 3163 Defining_Identifier => Expected_Comp, 3164 Object_Definition => New_Occurrence_Of (Comp_Type, Loc), 3165 Constant_Present => True, 3166 Expression => 3167 Unchecked_Convert_To (Comp_Type, 3168 Make_Function_Call (Loc, 3169 Name => New_Occurrence_Of (Read, Loc), 3170 Parameter_Associations => New_List ( 3171 Make_Attribute_Reference (Loc, 3172 Prefix => Relocate_Node (Comp_Sel_Nam), 3173 Attribute_Name => Name_Address))))); 3174 3175 -- Protected procedures 3176 3177 if Is_Procedure then 3178 -- Move the original declarations inside the generated block 3179 3180 Block_Decls := Decls; 3181 3182 -- Reset the declarations list of the protected procedure to 3183 -- contain only Decl. 3184 3185 Decls := New_List (Decl); 3186 3187 -- Generate: 3188 -- Desired_Comp : Comp_Type := Expected_Comp; 3189 3190 Desired_Comp := 3191 Make_Defining_Identifier (Loc, 3192 New_External_Name (Chars (Comp), Suffix => "_current")); 3193 3194 -- Insert the declarations of Expected_Comp and Desired_Comp in 3195 -- the block declarations right before the renaming of the 3196 -- protected component. 3197 3198 Insert_Before (Comp_Decl, 3199 Make_Object_Declaration (Loc, 3200 Defining_Identifier => Desired_Comp, 3201 Object_Definition => New_Occurrence_Of (Comp_Type, Loc), 3202 Expression => 3203 New_Occurrence_Of (Expected_Comp, Loc))); 3204 3205 -- Protected function 3206 3207 else 3208 Desired_Comp := Expected_Comp; 3209 3210 -- Insert the declaration of Expected_Comp in the function 3211 -- declarations right before the renaming of the protected 3212 -- component. 3213 3214 Insert_Before (Comp_Decl, Decl); 3215 end if; 3216 3217 -- Rewrite the protected component renaming declaration to be a 3218 -- renaming of Desired_Comp. 3219 3220 -- Generate: 3221 -- Comp : Comp_Type renames Desired_Comp; 3222 3223 Rewrite (Comp_Decl, 3224 Make_Object_Renaming_Declaration (Loc, 3225 Defining_Identifier => 3226 Defining_Identifier (Comp_Decl), 3227 Subtype_Mark => 3228 New_Occurrence_Of (Comp_Type, Loc), 3229 Name => 3230 New_Occurrence_Of (Desired_Comp, Loc))); 3231 3232 -- Wrap any return or raise statements in Stmts in same the manner 3233 -- described in Process_Stmts. 3234 3235 Process_Stmts (Stmts); 3236 3237 -- Generate: 3238 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N 3239 -- (_Object.Comp'Address, 3240 -- Interfaces.Unsigned_N (Expected_Comp), 3241 -- Interfaces.Unsigned_N (Desired_Comp)) 3242 3243 if Is_Procedure then 3244 Stmt := 3245 Make_Exit_Statement (Loc, 3246 Condition => 3247 Make_Function_Call (Loc, 3248 Name => 3249 New_Occurrence_Of (Try_Write, Loc), 3250 Parameter_Associations => New_List ( 3251 Make_Attribute_Reference (Loc, 3252 Prefix => Relocate_Node (Comp_Sel_Nam), 3253 Attribute_Name => Name_Address), 3254 3255 Unchecked_Convert_To (Unsigned, 3256 New_Occurrence_Of (Expected_Comp, Loc)), 3257 3258 Unchecked_Convert_To (Unsigned, 3259 New_Occurrence_Of (Desired_Comp, Loc))))); 3260 3261 -- Small optimization: transform the default return statement 3262 -- of a procedure into the atomic exit statement. 3263 3264 if Nkind (Last (Stmts)) = N_Simple_Return_Statement then 3265 Rewrite (Last (Stmts), Stmt); 3266 else 3267 Append_To (Stmts, Stmt); 3268 end if; 3269 end if; 3270 3271 -- Create the declaration of the label used to skip the rest of 3272 -- the source statements when the object state changes. 3273 3274 if Present (Label_Id) then 3275 Label := Make_Label (Loc, Label_Id); 3276 Append_To (Decls, 3277 Make_Implicit_Label_Declaration (Loc, 3278 Defining_Identifier => Entity (Label_Id), 3279 Label_Construct => Label)); 3280 Append_To (Stmts, Label); 3281 end if; 3282 3283 -- Generate: 3284 -- loop 3285 -- declare 3286 -- <Decls> 3287 -- begin 3288 -- <Stmts> 3289 -- end; 3290 -- end loop; 3291 3292 if Is_Procedure then 3293 Stmts := 3294 New_List ( 3295 Make_Loop_Statement (Loc, 3296 Statements => New_List ( 3297 Make_Block_Statement (Loc, 3298 Declarations => Block_Decls, 3299 Handled_Statement_Sequence => 3300 Make_Handled_Sequence_Of_Statements (Loc, 3301 Statements => Stmts))), 3302 End_Label => Empty)); 3303 end if; 3304 3305 Hand_Stmt_Seq := 3306 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts); 3307 end Protected_Component_Ref; 3308 end if; 3309 3310 -- Make an unprotected version of the subprogram for use within the same 3311 -- object, with new name and extra parameter representing the object. 3312 3313 return 3314 Make_Subprogram_Body (Loc, 3315 Specification => 3316 Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode), 3317 Declarations => Decls, 3318 Handled_Statement_Sequence => Hand_Stmt_Seq); 3319 end Build_Lock_Free_Unprotected_Subprogram_Body; 3320 3321 ------------------------- 3322 -- Build_Master_Entity -- 3323 ------------------------- 3324 3325 procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is 3326 Loc : constant Source_Ptr := Sloc (Obj_Or_Typ); 3327 Context : Node_Id; 3328 Context_Id : Entity_Id; 3329 Decl : Node_Id; 3330 Decls : List_Id; 3331 Par : Node_Id; 3332 3333 begin 3334 if Is_Itype (Obj_Or_Typ) then 3335 Par := Associated_Node_For_Itype (Obj_Or_Typ); 3336 else 3337 Par := Parent (Obj_Or_Typ); 3338 end if; 3339 3340 -- When creating a master for a record component which is either a task 3341 -- or access-to-task, the enclosing record is the master scope and the 3342 -- proper insertion point is the component list. 3343 3344 if Is_Record_Type (Current_Scope) then 3345 Context := Par; 3346 Context_Id := Current_Scope; 3347 Decls := List_Containing (Context); 3348 3349 -- Default case for object declarations and access types. Note that the 3350 -- context is updated to the nearest enclosing body, block, package, or 3351 -- return statement. 3352 3353 else 3354 Find_Enclosing_Context (Par, Context, Context_Id, Decls); 3355 end if; 3356 3357 -- Nothing to do if the context already has a master 3358 3359 if Has_Master_Entity (Context_Id) then 3360 return; 3361 3362 -- Nothing to do if tasks or tasking hierarchies are prohibited 3363 3364 elsif Restriction_Active (No_Tasking) 3365 or else Restriction_Active (No_Task_Hierarchy) 3366 then 3367 return; 3368 end if; 3369 3370 -- Create a master, generate: 3371 -- _Master : constant Master_Id := Current_Master.all; 3372 3373 Decl := 3374 Make_Object_Declaration (Loc, 3375 Defining_Identifier => 3376 Make_Defining_Identifier (Loc, Name_uMaster), 3377 Constant_Present => True, 3378 Object_Definition => New_Occurrence_Of (RTE (RE_Master_Id), Loc), 3379 Expression => 3380 Make_Explicit_Dereference (Loc, 3381 New_Occurrence_Of (RTE (RE_Current_Master), Loc))); 3382 3383 -- The master is inserted at the start of the declarative list of the 3384 -- context. 3385 3386 Prepend_To (Decls, Decl); 3387 3388 -- In certain cases where transient scopes are involved, the immediate 3389 -- scope is not always the proper master scope. Ensure that the master 3390 -- declaration and entity appear in the same context. 3391 3392 if Context_Id /= Current_Scope then 3393 Push_Scope (Context_Id); 3394 Analyze (Decl); 3395 Pop_Scope; 3396 else 3397 Analyze (Decl); 3398 end if; 3399 3400 -- Mark the enclosing scope and its associated construct as being task 3401 -- masters. 3402 3403 Set_Has_Master_Entity (Context_Id); 3404 3405 while Present (Context) 3406 and then Nkind (Context) /= N_Compilation_Unit 3407 loop 3408 if Nkind_In (Context, N_Block_Statement, 3409 N_Subprogram_Body, 3410 N_Task_Body) 3411 then 3412 Set_Is_Task_Master (Context); 3413 exit; 3414 3415 elsif Nkind (Parent (Context)) = N_Subunit then 3416 Context := Corresponding_Stub (Parent (Context)); 3417 end if; 3418 3419 Context := Parent (Context); 3420 end loop; 3421 end Build_Master_Entity; 3422 3423 --------------------------- 3424 -- Build_Master_Renaming -- 3425 --------------------------- 3426 3427 procedure Build_Master_Renaming 3428 (Ptr_Typ : Entity_Id; 3429 Ins_Nod : Node_Id := Empty) 3430 is 3431 Loc : constant Source_Ptr := Sloc (Ptr_Typ); 3432 Context : Node_Id; 3433 Master_Decl : Node_Id; 3434 Master_Id : Entity_Id; 3435 3436 begin 3437 -- Nothing to do if tasks or tasking hierarchies are prohibited 3438 3439 if Restriction_Active (No_Tasking) 3440 or else Restriction_Active (No_Task_Hierarchy) 3441 then 3442 return; 3443 end if; 3444 3445 -- Determine the proper context to insert the master renaming 3446 3447 if Present (Ins_Nod) then 3448 Context := Ins_Nod; 3449 elsif Is_Itype (Ptr_Typ) then 3450 Context := Associated_Node_For_Itype (Ptr_Typ); 3451 else 3452 Context := Parent (Ptr_Typ); 3453 end if; 3454 3455 -- Generate: 3456 -- <Ptr_Typ>M : Master_Id renames _Master; 3457 3458 Master_Id := 3459 Make_Defining_Identifier (Loc, 3460 New_External_Name (Chars (Ptr_Typ), 'M')); 3461 3462 Master_Decl := 3463 Make_Object_Renaming_Declaration (Loc, 3464 Defining_Identifier => Master_Id, 3465 Subtype_Mark => New_Occurrence_Of (RTE (RE_Master_Id), Loc), 3466 Name => Make_Identifier (Loc, Name_uMaster)); 3467 3468 Insert_Action (Context, Master_Decl); 3469 3470 -- The renamed master now services the access type 3471 3472 Set_Master_Id (Ptr_Typ, Master_Id); 3473 end Build_Master_Renaming; 3474 3475 ----------------------------------------- 3476 -- Build_Private_Protected_Declaration -- 3477 ----------------------------------------- 3478 3479 function Build_Private_Protected_Declaration 3480 (N : Node_Id) return Entity_Id 3481 is 3482 Loc : constant Source_Ptr := Sloc (N); 3483 Body_Id : constant Entity_Id := Defining_Entity (N); 3484 Decl : Node_Id; 3485 Plist : List_Id; 3486 Formal : Entity_Id; 3487 New_Spec : Node_Id; 3488 Spec_Id : Entity_Id; 3489 3490 begin 3491 Formal := First_Formal (Body_Id); 3492 3493 -- The protected operation always has at least one formal, namely the 3494 -- object itself, but it is only placed in the parameter list if 3495 -- expansion is enabled. 3496 3497 if Present (Formal) or else Expander_Active then 3498 Plist := Copy_Parameter_List (Body_Id); 3499 else 3500 Plist := No_List; 3501 end if; 3502 3503 if Nkind (Specification (N)) = N_Procedure_Specification then 3504 New_Spec := 3505 Make_Procedure_Specification (Loc, 3506 Defining_Unit_Name => 3507 Make_Defining_Identifier (Sloc (Body_Id), 3508 Chars => Chars (Body_Id)), 3509 Parameter_Specifications => 3510 Plist); 3511 else 3512 New_Spec := 3513 Make_Function_Specification (Loc, 3514 Defining_Unit_Name => 3515 Make_Defining_Identifier (Sloc (Body_Id), 3516 Chars => Chars (Body_Id)), 3517 Parameter_Specifications => Plist, 3518 Result_Definition => 3519 New_Occurrence_Of (Etype (Body_Id), Loc)); 3520 end if; 3521 3522 Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec); 3523 Insert_Before (N, Decl); 3524 Spec_Id := Defining_Unit_Name (New_Spec); 3525 3526 -- Indicate that the entity comes from source, to ensure that cross- 3527 -- reference information is properly generated. The body itself is 3528 -- rewritten during expansion, and the body entity will not appear in 3529 -- calls to the operation. 3530 3531 Set_Comes_From_Source (Spec_Id, True); 3532 Analyze (Decl); 3533 Set_Has_Completion (Spec_Id); 3534 Set_Convention (Spec_Id, Convention_Protected); 3535 return Spec_Id; 3536 end Build_Private_Protected_Declaration; 3537 3538 --------------------------- 3539 -- Build_Protected_Entry -- 3540 --------------------------- 3541 3542 function Build_Protected_Entry 3543 (N : Node_Id; 3544 Ent : Entity_Id; 3545 Pid : Node_Id) return Node_Id 3546 is 3547 Bod_Decls : constant List_Id := New_List; 3548 Decls : constant List_Id := Declarations (N); 3549 End_Lab : constant Node_Id := 3550 End_Label (Handled_Statement_Sequence (N)); 3551 End_Loc : constant Source_Ptr := 3552 Sloc (Last (Statements (Handled_Statement_Sequence (N)))); 3553 -- Used for the generated call to Complete_Entry_Body 3554 3555 Loc : constant Source_Ptr := Sloc (N); 3556 3557 Bod_Id : Entity_Id; 3558 Bod_Spec : Node_Id; 3559 Bod_Stmts : List_Id; 3560 Complete : Node_Id; 3561 Ohandle : Node_Id; 3562 3563 EH_Loc : Source_Ptr; 3564 -- Used for the exception handler, inserted at end of the body 3565 3566 begin 3567 -- Set the source location on the exception handler only when debugging 3568 -- the expanded code (see Make_Implicit_Exception_Handler). 3569 3570 if Debug_Generated_Code then 3571 EH_Loc := End_Loc; 3572 3573 -- Otherwise the inserted code should not be visible to the debugger 3574 3575 else 3576 EH_Loc := No_Location; 3577 end if; 3578 3579 Bod_Id := 3580 Make_Defining_Identifier (Loc, 3581 Chars => Chars (Protected_Body_Subprogram (Ent))); 3582 Bod_Spec := Build_Protected_Entry_Specification (Loc, Bod_Id, Empty); 3583 3584 -- Add the following declarations: 3585 3586 -- type poVP is access poV; 3587 -- _object : poVP := poVP (_O); 3588 3589 -- where _O is the formal parameter associated with the concurrent 3590 -- object. These declarations are needed for Complete_Entry_Body. 3591 3592 Add_Object_Pointer (Loc, Pid, Bod_Decls); 3593 3594 -- Add renamings for all formals, the Protection object, discriminals, 3595 -- privals and the entry index constant for use by debugger. 3596 3597 Add_Formal_Renamings (Bod_Spec, Bod_Decls, Ent, Loc); 3598 Debug_Private_Data_Declarations (Decls); 3599 3600 -- Put the declarations and the statements from the entry 3601 3602 Bod_Stmts := 3603 New_List ( 3604 Make_Block_Statement (Loc, 3605 Declarations => Decls, 3606 Handled_Statement_Sequence => Handled_Statement_Sequence (N))); 3607 3608 case Corresponding_Runtime_Package (Pid) is 3609 when System_Tasking_Protected_Objects_Entries => 3610 Append_To (Bod_Stmts, 3611 Make_Procedure_Call_Statement (End_Loc, 3612 Name => 3613 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc), 3614 Parameter_Associations => New_List ( 3615 Make_Attribute_Reference (End_Loc, 3616 Prefix => 3617 Make_Selected_Component (End_Loc, 3618 Prefix => 3619 Make_Identifier (End_Loc, Name_uObject), 3620 Selector_Name => 3621 Make_Identifier (End_Loc, Name_uObject)), 3622 Attribute_Name => Name_Unchecked_Access)))); 3623 3624 when System_Tasking_Protected_Objects_Single_Entry => 3625 3626 -- Historically, a call to Complete_Single_Entry_Body was 3627 -- inserted, but it was a null procedure. 3628 3629 null; 3630 3631 when others => 3632 raise Program_Error; 3633 end case; 3634 3635 -- When exceptions can not be propagated, we never need to call 3636 -- Exception_Complete_Entry_Body. 3637 3638 if No_Exception_Handlers_Set then 3639 return 3640 Make_Subprogram_Body (Loc, 3641 Specification => Bod_Spec, 3642 Declarations => Bod_Decls, 3643 Handled_Statement_Sequence => 3644 Make_Handled_Sequence_Of_Statements (Loc, 3645 Statements => Bod_Stmts, 3646 End_Label => End_Lab)); 3647 3648 else 3649 Ohandle := Make_Others_Choice (Loc); 3650 Set_All_Others (Ohandle); 3651 3652 case Corresponding_Runtime_Package (Pid) is 3653 when System_Tasking_Protected_Objects_Entries => 3654 Complete := 3655 New_Occurrence_Of 3656 (RTE (RE_Exceptional_Complete_Entry_Body), Loc); 3657 3658 when System_Tasking_Protected_Objects_Single_Entry => 3659 Complete := 3660 New_Occurrence_Of 3661 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); 3662 3663 when others => 3664 raise Program_Error; 3665 end case; 3666 3667 -- Establish link between subprogram body entity and source entry 3668 3669 Set_Corresponding_Protected_Entry (Bod_Id, Ent); 3670 3671 -- Create body of entry procedure. The renaming declarations are 3672 -- placed ahead of the block that contains the actual entry body. 3673 3674 return 3675 Make_Subprogram_Body (Loc, 3676 Specification => Bod_Spec, 3677 Declarations => Bod_Decls, 3678 Handled_Statement_Sequence => 3679 Make_Handled_Sequence_Of_Statements (Loc, 3680 Statements => Bod_Stmts, 3681 End_Label => End_Lab, 3682 Exception_Handlers => New_List ( 3683 Make_Implicit_Exception_Handler (EH_Loc, 3684 Exception_Choices => New_List (Ohandle), 3685 3686 Statements => New_List ( 3687 Make_Procedure_Call_Statement (EH_Loc, 3688 Name => Complete, 3689 Parameter_Associations => New_List ( 3690 Make_Attribute_Reference (EH_Loc, 3691 Prefix => 3692 Make_Selected_Component (EH_Loc, 3693 Prefix => 3694 Make_Identifier (EH_Loc, Name_uObject), 3695 Selector_Name => 3696 Make_Identifier (EH_Loc, Name_uObject)), 3697 Attribute_Name => Name_Unchecked_Access), 3698 3699 Make_Function_Call (EH_Loc, 3700 Name => 3701 New_Occurrence_Of 3702 (RTE (RE_Get_GNAT_Exception), Loc))))))))); 3703 end if; 3704 end Build_Protected_Entry; 3705 3706 ----------------------------------------- 3707 -- Build_Protected_Entry_Specification -- 3708 ----------------------------------------- 3709 3710 function Build_Protected_Entry_Specification 3711 (Loc : Source_Ptr; 3712 Def_Id : Entity_Id; 3713 Ent_Id : Entity_Id) return Node_Id 3714 is 3715 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP); 3716 3717 begin 3718 Set_Debug_Info_Needed (Def_Id); 3719 3720 if Present (Ent_Id) then 3721 Append_Elmt (P, Accept_Address (Ent_Id)); 3722 end if; 3723 3724 return 3725 Make_Procedure_Specification (Loc, 3726 Defining_Unit_Name => Def_Id, 3727 Parameter_Specifications => New_List ( 3728 Make_Parameter_Specification (Loc, 3729 Defining_Identifier => 3730 Make_Defining_Identifier (Loc, Name_uO), 3731 Parameter_Type => 3732 New_Occurrence_Of (RTE (RE_Address), Loc)), 3733 3734 Make_Parameter_Specification (Loc, 3735 Defining_Identifier => P, 3736 Parameter_Type => 3737 New_Occurrence_Of (RTE (RE_Address), Loc)), 3738 3739 Make_Parameter_Specification (Loc, 3740 Defining_Identifier => 3741 Make_Defining_Identifier (Loc, Name_uE), 3742 Parameter_Type => 3743 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)))); 3744 end Build_Protected_Entry_Specification; 3745 3746 -------------------------- 3747 -- Build_Protected_Spec -- 3748 -------------------------- 3749 3750 function Build_Protected_Spec 3751 (N : Node_Id; 3752 Obj_Type : Entity_Id; 3753 Ident : Entity_Id; 3754 Unprotected : Boolean := False) return List_Id 3755 is 3756 Loc : constant Source_Ptr := Sloc (N); 3757 Decl : Node_Id; 3758 Formal : Entity_Id; 3759 New_Plist : List_Id; 3760 New_Param : Node_Id; 3761 3762 begin 3763 New_Plist := New_List; 3764 3765 Formal := First_Formal (Ident); 3766 while Present (Formal) loop 3767 New_Param := 3768 Make_Parameter_Specification (Loc, 3769 Defining_Identifier => 3770 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 3771 Aliased_Present => Aliased_Present (Parent (Formal)), 3772 In_Present => In_Present (Parent (Formal)), 3773 Out_Present => Out_Present (Parent (Formal)), 3774 Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc)); 3775 3776 if Unprotected then 3777 Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); 3778 end if; 3779 3780 Append (New_Param, New_Plist); 3781 Next_Formal (Formal); 3782 end loop; 3783 3784 -- If the subprogram is a procedure and the context is not an access 3785 -- to protected subprogram, the parameter is in-out. Otherwise it is 3786 -- an in parameter. 3787 3788 Decl := 3789 Make_Parameter_Specification (Loc, 3790 Defining_Identifier => 3791 Make_Defining_Identifier (Loc, Name_uObject), 3792 In_Present => True, 3793 Out_Present => 3794 (Etype (Ident) = Standard_Void_Type 3795 and then not Is_RTE (Obj_Type, RE_Address)), 3796 Parameter_Type => 3797 New_Occurrence_Of (Obj_Type, Loc)); 3798 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 3799 Prepend_To (New_Plist, Decl); 3800 3801 return New_Plist; 3802 end Build_Protected_Spec; 3803 3804 --------------------------------------- 3805 -- Build_Protected_Sub_Specification -- 3806 --------------------------------------- 3807 3808 function Build_Protected_Sub_Specification 3809 (N : Node_Id; 3810 Prot_Typ : Entity_Id; 3811 Mode : Subprogram_Protection_Mode) return Node_Id 3812 is 3813 Loc : constant Source_Ptr := Sloc (N); 3814 Decl : Node_Id; 3815 Def_Id : Entity_Id; 3816 New_Id : Entity_Id; 3817 New_Plist : List_Id; 3818 New_Spec : Node_Id; 3819 3820 Append_Chr : constant array (Subprogram_Protection_Mode) of Character := 3821 (Dispatching_Mode => ' ', 3822 Protected_Mode => 'P', 3823 Unprotected_Mode => 'N'); 3824 3825 begin 3826 if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body 3827 then 3828 Decl := Unit_Declaration_Node (Corresponding_Spec (N)); 3829 else 3830 Decl := N; 3831 end if; 3832 3833 Def_Id := Defining_Unit_Name (Specification (Decl)); 3834 3835 New_Plist := 3836 Build_Protected_Spec 3837 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id, 3838 Mode = Unprotected_Mode); 3839 New_Id := 3840 Make_Defining_Identifier (Loc, 3841 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); 3842 3843 -- Reference the original nondispatching subprogram since the analysis 3844 -- of the object.operation notation may need its original name (see 3845 -- Sem_Ch4.Names_Match). 3846 3847 if Mode = Dispatching_Mode then 3848 Set_Ekind (New_Id, Ekind (Def_Id)); 3849 Set_Original_Protected_Subprogram (New_Id, Def_Id); 3850 end if; 3851 3852 -- Link the protected or unprotected version to the original subprogram 3853 -- it emulates. 3854 3855 Set_Ekind (New_Id, Ekind (Def_Id)); 3856 Set_Protected_Subprogram (New_Id, Def_Id); 3857 3858 -- The unprotected operation carries the user code, and debugging 3859 -- information must be generated for it, even though this spec does 3860 -- not come from source. It is also convenient to allow gdb to step 3861 -- into the protected operation, even though it only contains lock/ 3862 -- unlock calls. 3863 3864 Set_Debug_Info_Needed (New_Id); 3865 3866 -- If a pragma Eliminate applies to the source entity, the internal 3867 -- subprograms will be eliminated as well. 3868 3869 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id)); 3870 3871 if Nkind (Specification (Decl)) = N_Procedure_Specification then 3872 New_Spec := 3873 Make_Procedure_Specification (Loc, 3874 Defining_Unit_Name => New_Id, 3875 Parameter_Specifications => New_Plist); 3876 3877 -- Create a new specification for the anonymous subprogram type 3878 3879 else 3880 New_Spec := 3881 Make_Function_Specification (Loc, 3882 Defining_Unit_Name => New_Id, 3883 Parameter_Specifications => New_Plist, 3884 Result_Definition => 3885 Copy_Result_Type (Result_Definition (Specification (Decl)))); 3886 3887 Set_Return_Present (Defining_Unit_Name (New_Spec)); 3888 end if; 3889 3890 return New_Spec; 3891 end Build_Protected_Sub_Specification; 3892 3893 ------------------------------------- 3894 -- Build_Protected_Subprogram_Body -- 3895 ------------------------------------- 3896 3897 function Build_Protected_Subprogram_Body 3898 (N : Node_Id; 3899 Pid : Node_Id; 3900 N_Op_Spec : Node_Id) return Node_Id 3901 is 3902 Exc_Safe : constant Boolean := not Might_Raise (N); 3903 -- True if N cannot raise an exception 3904 3905 Loc : constant Source_Ptr := Sloc (N); 3906 Op_Spec : constant Node_Id := Specification (N); 3907 P_Op_Spec : constant Node_Id := 3908 Build_Protected_Sub_Specification (N, Pid, Protected_Mode); 3909 3910 Lock_Kind : RE_Id; 3911 Lock_Name : Node_Id; 3912 Lock_Stmt : Node_Id; 3913 Object_Parm : Node_Id; 3914 Pformal : Node_Id; 3915 R : Node_Id; 3916 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning 3917 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning 3918 Stmts : List_Id; 3919 Sub_Body : Node_Id; 3920 Uactuals : List_Id; 3921 Unprot_Call : Node_Id; 3922 3923 begin 3924 -- Build a list of the formal parameters of the protected version of 3925 -- the subprogram to use as the actual parameters of the unprotected 3926 -- version. 3927 3928 Uactuals := New_List; 3929 Pformal := First (Parameter_Specifications (P_Op_Spec)); 3930 while Present (Pformal) loop 3931 Append_To (Uactuals, 3932 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal)))); 3933 Next (Pformal); 3934 end loop; 3935 3936 -- Make a call to the unprotected version of the subprogram built above 3937 -- for use by the protected version built below. 3938 3939 if Nkind (Op_Spec) = N_Function_Specification then 3940 if Exc_Safe then 3941 R := Make_Temporary (Loc, 'R'); 3942 3943 Unprot_Call := 3944 Make_Object_Declaration (Loc, 3945 Defining_Identifier => R, 3946 Constant_Present => True, 3947 Object_Definition => 3948 New_Copy (Result_Definition (N_Op_Spec)), 3949 Expression => 3950 Make_Function_Call (Loc, 3951 Name => 3952 Make_Identifier (Loc, 3953 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 3954 Parameter_Associations => Uactuals)); 3955 3956 Return_Stmt := 3957 Make_Simple_Return_Statement (Loc, 3958 Expression => New_Occurrence_Of (R, Loc)); 3959 3960 else 3961 Unprot_Call := 3962 Make_Simple_Return_Statement (Loc, 3963 Expression => 3964 Make_Function_Call (Loc, 3965 Name => 3966 Make_Identifier (Loc, 3967 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 3968 Parameter_Associations => Uactuals)); 3969 end if; 3970 3971 Lock_Kind := RE_Lock_Read_Only; 3972 3973 else 3974 Unprot_Call := 3975 Make_Procedure_Call_Statement (Loc, 3976 Name => 3977 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), 3978 Parameter_Associations => Uactuals); 3979 3980 Lock_Kind := RE_Lock; 3981 end if; 3982 3983 -- Wrap call in block that will be covered by an at_end handler 3984 3985 if not Exc_Safe then 3986 Unprot_Call := 3987 Make_Block_Statement (Loc, 3988 Handled_Statement_Sequence => 3989 Make_Handled_Sequence_Of_Statements (Loc, 3990 Statements => New_List (Unprot_Call))); 3991 end if; 3992 3993 -- Make the protected subprogram body. This locks the protected 3994 -- object and calls the unprotected version of the subprogram. 3995 3996 case Corresponding_Runtime_Package (Pid) is 3997 when System_Tasking_Protected_Objects_Entries => 3998 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc); 3999 4000 when System_Tasking_Protected_Objects_Single_Entry => 4001 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc); 4002 4003 when System_Tasking_Protected_Objects => 4004 Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc); 4005 4006 when others => 4007 raise Program_Error; 4008 end case; 4009 4010 Object_Parm := 4011 Make_Attribute_Reference (Loc, 4012 Prefix => 4013 Make_Selected_Component (Loc, 4014 Prefix => Make_Identifier (Loc, Name_uObject), 4015 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4016 Attribute_Name => Name_Unchecked_Access); 4017 4018 Lock_Stmt := 4019 Make_Procedure_Call_Statement (Loc, 4020 Name => Lock_Name, 4021 Parameter_Associations => New_List (Object_Parm)); 4022 4023 if Abort_Allowed then 4024 Stmts := New_List ( 4025 Build_Runtime_Call (Loc, RE_Abort_Defer), 4026 Lock_Stmt); 4027 4028 else 4029 Stmts := New_List (Lock_Stmt); 4030 end if; 4031 4032 if not Exc_Safe then 4033 Append (Unprot_Call, Stmts); 4034 else 4035 if Nkind (Op_Spec) = N_Function_Specification then 4036 Pre_Stmts := Stmts; 4037 Stmts := Empty_List; 4038 else 4039 Append (Unprot_Call, Stmts); 4040 end if; 4041 4042 -- Historical note: Previously, call to the cleanup was inserted 4043 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup, 4044 -- which is also shared by the 'not Exc_Safe' path. 4045 4046 Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts); 4047 4048 if Nkind (Op_Spec) = N_Function_Specification then 4049 Append_To (Stmts, Return_Stmt); 4050 Append_To (Pre_Stmts, 4051 Make_Block_Statement (Loc, 4052 Declarations => New_List (Unprot_Call), 4053 Handled_Statement_Sequence => 4054 Make_Handled_Sequence_Of_Statements (Loc, 4055 Statements => Stmts))); 4056 Stmts := Pre_Stmts; 4057 end if; 4058 end if; 4059 4060 Sub_Body := 4061 Make_Subprogram_Body (Loc, 4062 Declarations => Empty_List, 4063 Specification => P_Op_Spec, 4064 Handled_Statement_Sequence => 4065 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); 4066 4067 -- Mark this subprogram as a protected subprogram body so that the 4068 -- cleanup will be inserted. This is done only in the 'not Exc_Safe' 4069 -- path as otherwise the cleanup has already been inserted. 4070 4071 if not Exc_Safe then 4072 Set_Is_Protected_Subprogram_Body (Sub_Body); 4073 end if; 4074 4075 return Sub_Body; 4076 end Build_Protected_Subprogram_Body; 4077 4078 ------------------------------------- 4079 -- Build_Protected_Subprogram_Call -- 4080 ------------------------------------- 4081 4082 procedure Build_Protected_Subprogram_Call 4083 (N : Node_Id; 4084 Name : Node_Id; 4085 Rec : Node_Id; 4086 External : Boolean := True) 4087 is 4088 Loc : constant Source_Ptr := Sloc (N); 4089 Sub : constant Entity_Id := Entity (Name); 4090 New_Sub : Node_Id; 4091 Params : List_Id; 4092 4093 begin 4094 if External then 4095 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc); 4096 else 4097 New_Sub := 4098 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc); 4099 end if; 4100 4101 if Present (Parameter_Associations (N)) then 4102 Params := New_Copy_List_Tree (Parameter_Associations (N)); 4103 else 4104 Params := New_List; 4105 end if; 4106 4107 -- If the type is an untagged derived type, convert to the root type, 4108 -- which is the one on which the operations are defined. 4109 4110 if Nkind (Rec) = N_Unchecked_Type_Conversion 4111 and then not Is_Tagged_Type (Etype (Rec)) 4112 and then Is_Derived_Type (Etype (Rec)) 4113 then 4114 Set_Etype (Rec, Root_Type (Etype (Rec))); 4115 Set_Subtype_Mark (Rec, 4116 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N))); 4117 end if; 4118 4119 Prepend (Rec, Params); 4120 4121 if Ekind (Sub) = E_Procedure then 4122 Rewrite (N, 4123 Make_Procedure_Call_Statement (Loc, 4124 Name => New_Sub, 4125 Parameter_Associations => Params)); 4126 4127 else 4128 pragma Assert (Ekind (Sub) = E_Function); 4129 Rewrite (N, 4130 Make_Function_Call (Loc, 4131 Name => New_Sub, 4132 Parameter_Associations => Params)); 4133 4134 -- Preserve type of call for subsequent processing (required for 4135 -- call to Wrap_Transient_Expression in the case of a shared passive 4136 -- protected). 4137 4138 Set_Etype (N, Etype (New_Sub)); 4139 end if; 4140 4141 if External 4142 and then Nkind (Rec) = N_Unchecked_Type_Conversion 4143 and then Is_Entity_Name (Expression (Rec)) 4144 and then Is_Shared_Passive (Entity (Expression (Rec))) 4145 then 4146 Add_Shared_Var_Lock_Procs (N); 4147 end if; 4148 end Build_Protected_Subprogram_Call; 4149 4150 --------------------------------------------- 4151 -- Build_Protected_Subprogram_Call_Cleanup -- 4152 --------------------------------------------- 4153 4154 procedure Build_Protected_Subprogram_Call_Cleanup 4155 (Op_Spec : Node_Id; 4156 Conc_Typ : Node_Id; 4157 Loc : Source_Ptr; 4158 Stmts : List_Id) 4159 is 4160 Nam : Node_Id; 4161 4162 begin 4163 -- If the associated protected object has entries, a protected 4164 -- procedure has to service entry queues. In this case generate: 4165 4166 -- Service_Entries (_object._object'Access); 4167 4168 if Nkind (Op_Spec) = N_Procedure_Specification 4169 and then Has_Entries (Conc_Typ) 4170 then 4171 case Corresponding_Runtime_Package (Conc_Typ) is 4172 when System_Tasking_Protected_Objects_Entries => 4173 Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc); 4174 4175 when System_Tasking_Protected_Objects_Single_Entry => 4176 Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc); 4177 4178 when others => 4179 raise Program_Error; 4180 end case; 4181 4182 Append_To (Stmts, 4183 Make_Procedure_Call_Statement (Loc, 4184 Name => Nam, 4185 Parameter_Associations => New_List ( 4186 Make_Attribute_Reference (Loc, 4187 Prefix => 4188 Make_Selected_Component (Loc, 4189 Prefix => Make_Identifier (Loc, Name_uObject), 4190 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4191 Attribute_Name => Name_Unchecked_Access)))); 4192 4193 else 4194 -- Generate: 4195 -- Unlock (_object._object'Access); 4196 4197 case Corresponding_Runtime_Package (Conc_Typ) is 4198 when System_Tasking_Protected_Objects_Entries => 4199 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc); 4200 4201 when System_Tasking_Protected_Objects_Single_Entry => 4202 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc); 4203 4204 when System_Tasking_Protected_Objects => 4205 Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc); 4206 4207 when others => 4208 raise Program_Error; 4209 end case; 4210 4211 Append_To (Stmts, 4212 Make_Procedure_Call_Statement (Loc, 4213 Name => Nam, 4214 Parameter_Associations => New_List ( 4215 Make_Attribute_Reference (Loc, 4216 Prefix => 4217 Make_Selected_Component (Loc, 4218 Prefix => Make_Identifier (Loc, Name_uObject), 4219 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4220 Attribute_Name => Name_Unchecked_Access)))); 4221 end if; 4222 4223 -- Generate: 4224 -- Abort_Undefer; 4225 4226 if Abort_Allowed then 4227 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 4228 end if; 4229 end Build_Protected_Subprogram_Call_Cleanup; 4230 4231 ------------------------- 4232 -- Build_Selected_Name -- 4233 ------------------------- 4234 4235 function Build_Selected_Name 4236 (Prefix : Entity_Id; 4237 Selector : Entity_Id; 4238 Append_Char : Character := ' ') return Name_Id 4239 is 4240 Select_Buffer : String (1 .. Hostparm.Max_Name_Length); 4241 Select_Len : Natural; 4242 4243 begin 4244 Get_Name_String (Chars (Selector)); 4245 Select_Len := Name_Len; 4246 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len); 4247 Get_Name_String (Chars (Prefix)); 4248 4249 -- If scope is anonymous type, discard suffix to recover name of 4250 -- single protected object. Otherwise use protected type name. 4251 4252 if Name_Buffer (Name_Len) = 'T' then 4253 Name_Len := Name_Len - 1; 4254 end if; 4255 4256 Add_Str_To_Name_Buffer ("__"); 4257 for J in 1 .. Select_Len loop 4258 Add_Char_To_Name_Buffer (Select_Buffer (J)); 4259 end loop; 4260 4261 -- Now add the Append_Char if specified. The encoding to follow 4262 -- depends on the type of entity. If Append_Char is either 'N' or 'P', 4263 -- then the entity is associated to a protected type subprogram. 4264 -- Otherwise, it is a protected type entry. For each case, the 4265 -- encoding to follow for the suffix is documented in exp_dbug.ads. 4266 4267 -- It would be better to encapsulate this as a routine in Exp_Dbug ??? 4268 4269 if Append_Char /= ' ' then 4270 if Append_Char = 'P' or Append_Char = 'N' then 4271 Add_Char_To_Name_Buffer (Append_Char); 4272 return Name_Find; 4273 else 4274 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char)); 4275 return New_External_Name (Name_Find, ' ', -1); 4276 end if; 4277 else 4278 return Name_Find; 4279 end if; 4280 end Build_Selected_Name; 4281 4282 ----------------------------- 4283 -- Build_Simple_Entry_Call -- 4284 ----------------------------- 4285 4286 -- A task entry call is converted to a call to Call_Simple 4287 4288 -- declare 4289 -- P : parms := (parm, parm, parm); 4290 -- begin 4291 -- Call_Simple (acceptor-task, entry-index, P'Address); 4292 -- parm := P.param; 4293 -- parm := P.param; 4294 -- ... 4295 -- end; 4296 4297 -- Here Pnn is an aggregate of the type constructed for the entry to hold 4298 -- the parameters, and the constructed aggregate value contains either the 4299 -- parameters or, in the case of non-elementary types, references to these 4300 -- parameters. Then the address of this aggregate is passed to the runtime 4301 -- routine, along with the task id value and the task entry index value. 4302 -- Pnn is only required if parameters are present. 4303 4304 -- The assignments after the call are present only in the case of in-out 4305 -- or out parameters for elementary types, and are used to assign back the 4306 -- resulting values of such parameters. 4307 4308 -- Note: the reason that we insert a block here is that in the context 4309 -- of selects, conditional entry calls etc. the entry call statement 4310 -- appears on its own, not as an element of a list. 4311 4312 -- A protected entry call is converted to a Protected_Entry_Call: 4313 4314 -- declare 4315 -- P : E1_Params := (param, param, param); 4316 -- Pnn : Boolean; 4317 -- Bnn : Communications_Block; 4318 4319 -- declare 4320 -- P : E1_Params := (param, param, param); 4321 -- Bnn : Communications_Block; 4322 4323 -- begin 4324 -- Protected_Entry_Call ( 4325 -- Object => po._object'Access, 4326 -- E => <entry index>; 4327 -- Uninterpreted_Data => P'Address; 4328 -- Mode => Simple_Call; 4329 -- Block => Bnn); 4330 -- parm := P.param; 4331 -- parm := P.param; 4332 -- ... 4333 -- end; 4334 4335 procedure Build_Simple_Entry_Call 4336 (N : Node_Id; 4337 Concval : Node_Id; 4338 Ename : Node_Id; 4339 Index : Node_Id) 4340 is 4341 begin 4342 Expand_Call (N); 4343 4344 -- If call has been inlined, nothing left to do 4345 4346 if Nkind (N) = N_Block_Statement then 4347 return; 4348 end if; 4349 4350 -- Convert entry call to Call_Simple call 4351 4352 declare 4353 Loc : constant Source_Ptr := Sloc (N); 4354 Parms : constant List_Id := Parameter_Associations (N); 4355 Stats : constant List_Id := New_List; 4356 Actual : Node_Id; 4357 Call : Node_Id; 4358 Comm_Name : Entity_Id; 4359 Conctyp : Node_Id; 4360 Decls : List_Id; 4361 Ent : Entity_Id; 4362 Ent_Acc : Entity_Id; 4363 Formal : Node_Id; 4364 Iface_Tag : Entity_Id; 4365 Iface_Typ : Entity_Id; 4366 N_Node : Node_Id; 4367 N_Var : Node_Id; 4368 P : Entity_Id; 4369 Parm1 : Node_Id; 4370 Parm2 : Node_Id; 4371 Parm3 : Node_Id; 4372 Pdecl : Node_Id; 4373 Plist : List_Id; 4374 X : Entity_Id; 4375 Xdecl : Node_Id; 4376 4377 begin 4378 -- Simple entry and entry family cases merge here 4379 4380 Ent := Entity (Ename); 4381 Ent_Acc := Entry_Parameters_Type (Ent); 4382 Conctyp := Etype (Concval); 4383 4384 -- If prefix is an access type, dereference to obtain the task type 4385 4386 if Is_Access_Type (Conctyp) then 4387 Conctyp := Designated_Type (Conctyp); 4388 end if; 4389 4390 -- Special case for protected subprogram calls 4391 4392 if Is_Protected_Type (Conctyp) 4393 and then Is_Subprogram (Entity (Ename)) 4394 then 4395 if not Is_Eliminated (Entity (Ename)) then 4396 Build_Protected_Subprogram_Call 4397 (N, Ename, Convert_Concurrent (Concval, Conctyp)); 4398 Analyze (N); 4399 end if; 4400 4401 return; 4402 end if; 4403 4404 -- First parameter is the Task_Id value from the task value or the 4405 -- Object from the protected object value, obtained by selecting 4406 -- the _Task_Id or _Object from the result of doing an unchecked 4407 -- conversion to convert the value to the corresponding record type. 4408 4409 if Nkind (Concval) = N_Function_Call 4410 and then Is_Task_Type (Conctyp) 4411 and then Ada_Version >= Ada_2005 4412 then 4413 declare 4414 ExpR : constant Node_Id := Relocate_Node (Concval); 4415 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR); 4416 Decl : Node_Id; 4417 4418 begin 4419 Decl := 4420 Make_Object_Declaration (Loc, 4421 Defining_Identifier => Obj, 4422 Object_Definition => New_Occurrence_Of (Conctyp, Loc), 4423 Expression => ExpR); 4424 Set_Etype (Obj, Conctyp); 4425 Decls := New_List (Decl); 4426 Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); 4427 end; 4428 4429 else 4430 Decls := New_List; 4431 end if; 4432 4433 Parm1 := Concurrent_Ref (Concval); 4434 4435 -- Second parameter is the entry index, computed by the routine 4436 -- provided for this purpose. The value of this expression is 4437 -- assigned to an intermediate variable to assure that any entry 4438 -- family index expressions are evaluated before the entry 4439 -- parameters. 4440 4441 if not Is_Protected_Type (Conctyp) 4442 or else 4443 Corresponding_Runtime_Package (Conctyp) = 4444 System_Tasking_Protected_Objects_Entries 4445 then 4446 X := Make_Defining_Identifier (Loc, Name_uX); 4447 4448 Xdecl := 4449 Make_Object_Declaration (Loc, 4450 Defining_Identifier => X, 4451 Object_Definition => 4452 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), 4453 Expression => Actual_Index_Expression ( 4454 Loc, Entity (Ename), Index, Concval)); 4455 4456 Append_To (Decls, Xdecl); 4457 Parm2 := New_Occurrence_Of (X, Loc); 4458 4459 else 4460 Xdecl := Empty; 4461 Parm2 := Empty; 4462 end if; 4463 4464 -- The third parameter is the packaged parameters. If there are 4465 -- none, then it is just the null address, since nothing is passed. 4466 4467 if No (Parms) then 4468 Parm3 := New_Occurrence_Of (RTE (RE_Null_Address), Loc); 4469 P := Empty; 4470 4471 -- Case of parameters present, where third argument is the address 4472 -- of a packaged record containing the required parameter values. 4473 4474 else 4475 -- First build a list of parameter values, which are references to 4476 -- objects of the parameter types. 4477 4478 Plist := New_List; 4479 4480 Actual := First_Actual (N); 4481 Formal := First_Formal (Ent); 4482 while Present (Actual) loop 4483 4484 -- If it is a by-copy type, copy it to a new variable. The 4485 -- packaged record has a field that points to this variable. 4486 4487 if Is_By_Copy_Type (Etype (Actual)) then 4488 N_Node := 4489 Make_Object_Declaration (Loc, 4490 Defining_Identifier => Make_Temporary (Loc, 'J'), 4491 Aliased_Present => True, 4492 Object_Definition => 4493 New_Occurrence_Of (Etype (Formal), Loc)); 4494 4495 -- Mark the object as not needing initialization since the 4496 -- initialization is performed separately, avoiding errors 4497 -- on cases such as formals of null-excluding access types. 4498 4499 Set_No_Initialization (N_Node); 4500 4501 -- We must make a separate assignment statement for the 4502 -- case of limited types. We cannot assign it unless the 4503 -- Assignment_OK flag is set first. An out formal of an 4504 -- access type or whose type has a Default_Value must also 4505 -- be initialized from the actual (see RM 6.4.1 (13-13.1)), 4506 -- but no constraint, predicate, or null-exclusion check is 4507 -- applied before the call. 4508 4509 if Ekind (Formal) /= E_Out_Parameter 4510 or else Is_Access_Type (Etype (Formal)) 4511 or else 4512 (Is_Scalar_Type (Etype (Formal)) 4513 and then 4514 Present (Default_Aspect_Value (Etype (Formal)))) 4515 then 4516 N_Var := 4517 New_Occurrence_Of (Defining_Identifier (N_Node), Loc); 4518 Set_Assignment_OK (N_Var); 4519 Append_To (Stats, 4520 Make_Assignment_Statement (Loc, 4521 Name => N_Var, 4522 Expression => Relocate_Node (Actual))); 4523 4524 -- Mark the object as internal, so we don't later reset 4525 -- No_Initialization flag in Default_Initialize_Object, 4526 -- which would lead to needless default initialization. 4527 -- We don't set this outside the if statement, because 4528 -- out scalar parameters without Default_Value do require 4529 -- default initialization if Initialize_Scalars applies. 4530 4531 Set_Is_Internal (Defining_Identifier (N_Node)); 4532 4533 -- If actual is an out parameter of a null-excluding 4534 -- access type, there is access check on entry, so set 4535 -- Suppress_Assignment_Checks on the generated statement 4536 -- that assigns the actual to the parameter block. 4537 4538 Set_Suppress_Assignment_Checks (Last (Stats)); 4539 end if; 4540 4541 Append (N_Node, Decls); 4542 4543 Append_To (Plist, 4544 Make_Attribute_Reference (Loc, 4545 Attribute_Name => Name_Unchecked_Access, 4546 Prefix => 4547 New_Occurrence_Of 4548 (Defining_Identifier (N_Node), Loc))); 4549 4550 else 4551 -- Interface class-wide formal 4552 4553 if Ada_Version >= Ada_2005 4554 and then Ekind (Etype (Formal)) = E_Class_Wide_Type 4555 and then Is_Interface (Etype (Formal)) 4556 then 4557 Iface_Typ := Etype (Etype (Formal)); 4558 4559 -- Generate: 4560 -- formal_iface_type! (actual.iface_tag)'reference 4561 4562 Iface_Tag := 4563 Find_Interface_Tag (Etype (Actual), Iface_Typ); 4564 pragma Assert (Present (Iface_Tag)); 4565 4566 Append_To (Plist, 4567 Make_Reference (Loc, 4568 Unchecked_Convert_To (Iface_Typ, 4569 Make_Selected_Component (Loc, 4570 Prefix => 4571 Relocate_Node (Actual), 4572 Selector_Name => 4573 New_Occurrence_Of (Iface_Tag, Loc))))); 4574 else 4575 -- Generate: 4576 -- actual'reference 4577 4578 Append_To (Plist, 4579 Make_Reference (Loc, Relocate_Node (Actual))); 4580 end if; 4581 end if; 4582 4583 Next_Actual (Actual); 4584 Next_Formal_With_Extras (Formal); 4585 end loop; 4586 4587 -- Now build the declaration of parameters initialized with the 4588 -- aggregate containing this constructed parameter list. 4589 4590 P := Make_Defining_Identifier (Loc, Name_uP); 4591 4592 Pdecl := 4593 Make_Object_Declaration (Loc, 4594 Defining_Identifier => P, 4595 Object_Definition => 4596 New_Occurrence_Of (Designated_Type (Ent_Acc), Loc), 4597 Expression => 4598 Make_Aggregate (Loc, Expressions => Plist)); 4599 4600 Parm3 := 4601 Make_Attribute_Reference (Loc, 4602 Prefix => New_Occurrence_Of (P, Loc), 4603 Attribute_Name => Name_Address); 4604 4605 Append (Pdecl, Decls); 4606 end if; 4607 4608 -- Now we can create the call, case of protected type 4609 4610 if Is_Protected_Type (Conctyp) then 4611 case Corresponding_Runtime_Package (Conctyp) is 4612 when System_Tasking_Protected_Objects_Entries => 4613 4614 -- Change the type of the index declaration 4615 4616 Set_Object_Definition (Xdecl, 4617 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)); 4618 4619 -- Some additional declarations for protected entry calls 4620 4621 if No (Decls) then 4622 Decls := New_List; 4623 end if; 4624 4625 -- Bnn : Communications_Block; 4626 4627 Comm_Name := Make_Temporary (Loc, 'B'); 4628 4629 Append_To (Decls, 4630 Make_Object_Declaration (Loc, 4631 Defining_Identifier => Comm_Name, 4632 Object_Definition => 4633 New_Occurrence_Of 4634 (RTE (RE_Communication_Block), Loc))); 4635 4636 -- Some additional statements for protected entry calls 4637 4638 -- Protected_Entry_Call 4639 -- (Object => po._object'Access, 4640 -- E => <entry index>; 4641 -- Uninterpreted_Data => P'Address; 4642 -- Mode => Simple_Call; 4643 -- Block => Bnn); 4644 4645 Call := 4646 Make_Procedure_Call_Statement (Loc, 4647 Name => 4648 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), 4649 4650 Parameter_Associations => New_List ( 4651 Make_Attribute_Reference (Loc, 4652 Attribute_Name => Name_Unchecked_Access, 4653 Prefix => Parm1), 4654 Parm2, 4655 Parm3, 4656 New_Occurrence_Of (RTE (RE_Simple_Call), Loc), 4657 New_Occurrence_Of (Comm_Name, Loc))); 4658 4659 when System_Tasking_Protected_Objects_Single_Entry => 4660 4661 -- Protected_Single_Entry_Call 4662 -- (Object => po._object'Access, 4663 -- Uninterpreted_Data => P'Address); 4664 4665 Call := 4666 Make_Procedure_Call_Statement (Loc, 4667 Name => 4668 New_Occurrence_Of 4669 (RTE (RE_Protected_Single_Entry_Call), Loc), 4670 4671 Parameter_Associations => New_List ( 4672 Make_Attribute_Reference (Loc, 4673 Attribute_Name => Name_Unchecked_Access, 4674 Prefix => Parm1), 4675 Parm3)); 4676 4677 when others => 4678 raise Program_Error; 4679 end case; 4680 4681 -- Case of task type 4682 4683 else 4684 Call := 4685 Make_Procedure_Call_Statement (Loc, 4686 Name => 4687 New_Occurrence_Of (RTE (RE_Call_Simple), Loc), 4688 Parameter_Associations => New_List (Parm1, Parm2, Parm3)); 4689 4690 end if; 4691 4692 Append_To (Stats, Call); 4693 4694 -- If there are out or in/out parameters by copy add assignment 4695 -- statements for the result values. 4696 4697 if Present (Parms) then 4698 Actual := First_Actual (N); 4699 Formal := First_Formal (Ent); 4700 4701 Set_Assignment_OK (Actual); 4702 while Present (Actual) loop 4703 if Is_By_Copy_Type (Etype (Actual)) 4704 and then Ekind (Formal) /= E_In_Parameter 4705 then 4706 N_Node := 4707 Make_Assignment_Statement (Loc, 4708 Name => New_Copy (Actual), 4709 Expression => 4710 Make_Explicit_Dereference (Loc, 4711 Make_Selected_Component (Loc, 4712 Prefix => New_Occurrence_Of (P, Loc), 4713 Selector_Name => 4714 Make_Identifier (Loc, Chars (Formal))))); 4715 4716 -- In all cases (including limited private types) we want 4717 -- the assignment to be valid. 4718 4719 Set_Assignment_OK (Name (N_Node)); 4720 4721 -- If the call is the triggering alternative in an 4722 -- asynchronous select, or the entry_call alternative of a 4723 -- conditional entry call, the assignments for in-out 4724 -- parameters are incorporated into the statement list that 4725 -- follows, so that there are executed only if the entry 4726 -- call succeeds. 4727 4728 if (Nkind (Parent (N)) = N_Triggering_Alternative 4729 and then N = Triggering_Statement (Parent (N))) 4730 or else 4731 (Nkind (Parent (N)) = N_Entry_Call_Alternative 4732 and then N = Entry_Call_Statement (Parent (N))) 4733 then 4734 if No (Statements (Parent (N))) then 4735 Set_Statements (Parent (N), New_List); 4736 end if; 4737 4738 Prepend (N_Node, Statements (Parent (N))); 4739 4740 else 4741 Insert_After (Call, N_Node); 4742 end if; 4743 end if; 4744 4745 Next_Actual (Actual); 4746 Next_Formal_With_Extras (Formal); 4747 end loop; 4748 end if; 4749 4750 -- Finally, create block and analyze it 4751 4752 Rewrite (N, 4753 Make_Block_Statement (Loc, 4754 Declarations => Decls, 4755 Handled_Statement_Sequence => 4756 Make_Handled_Sequence_Of_Statements (Loc, 4757 Statements => Stats))); 4758 4759 Analyze (N); 4760 end; 4761 end Build_Simple_Entry_Call; 4762 4763 -------------------------------- 4764 -- Build_Task_Activation_Call -- 4765 -------------------------------- 4766 4767 procedure Build_Task_Activation_Call (N : Node_Id) is 4768 function Activation_Call_Loc return Source_Ptr; 4769 -- Find a suitable source location for the activation call 4770 4771 ------------------------- 4772 -- Activation_Call_Loc -- 4773 ------------------------- 4774 4775 function Activation_Call_Loc return Source_Ptr is 4776 begin 4777 -- The activation call must carry the location of the "end" keyword 4778 -- when the context is a package declaration. 4779 4780 if Nkind (N) = N_Package_Declaration then 4781 return End_Keyword_Location (N); 4782 4783 -- Otherwise the activation call must carry the location of the 4784 -- "begin" keyword. 4785 4786 else 4787 return Begin_Keyword_Location (N); 4788 end if; 4789 end Activation_Call_Loc; 4790 4791 -- Local variables 4792 4793 Chain : Entity_Id; 4794 Call : Node_Id; 4795 Loc : Source_Ptr; 4796 Name : Node_Id; 4797 Owner : Node_Id; 4798 Stmt : Node_Id; 4799 4800 -- Start of processing for Build_Task_Activation_Call 4801 4802 begin 4803 -- For sequential elaboration policy, all the tasks will be activated at 4804 -- the end of the elaboration. 4805 4806 if Partition_Elaboration_Policy = 'S' then 4807 return; 4808 4809 -- Do not create an activation call for a package spec if the package 4810 -- has a completing body. The activation call will be inserted after 4811 -- the "begin" of the body. 4812 4813 elsif Nkind (N) = N_Package_Declaration 4814 and then Present (Corresponding_Body (N)) 4815 then 4816 return; 4817 end if; 4818 4819 -- Obtain the activation chain entity. Block statements, entry bodies, 4820 -- subprogram bodies, and task bodies keep the entity in their nodes. 4821 -- Package bodies on the other hand store it in the declaration of the 4822 -- corresponding package spec. 4823 4824 Owner := N; 4825 4826 if Nkind (Owner) = N_Package_Body then 4827 Owner := Unit_Declaration_Node (Corresponding_Spec (Owner)); 4828 end if; 4829 4830 Chain := Activation_Chain_Entity (Owner); 4831 4832 -- Nothing to do when there are no tasks to activate. This is indicated 4833 -- by a missing activation chain entity. 4834 4835 if No (Chain) then 4836 return; 4837 end if; 4838 4839 -- The location of the activation call must be as close as possible to 4840 -- the intended semantic location of the activation because the ABE 4841 -- mechanism relies heavily on accurate locations. 4842 4843 Loc := Activation_Call_Loc; 4844 4845 if Restricted_Profile then 4846 Name := New_Occurrence_Of (RTE (RE_Activate_Restricted_Tasks), Loc); 4847 else 4848 Name := New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc); 4849 end if; 4850 4851 Call := 4852 Make_Procedure_Call_Statement (Loc, 4853 Name => Name, 4854 Parameter_Associations => 4855 New_List (Make_Attribute_Reference (Loc, 4856 Prefix => New_Occurrence_Of (Chain, Loc), 4857 Attribute_Name => Name_Unchecked_Access))); 4858 4859 if Nkind (N) = N_Package_Declaration then 4860 if Present (Private_Declarations (Specification (N))) then 4861 Append (Call, Private_Declarations (Specification (N))); 4862 else 4863 Append (Call, Visible_Declarations (Specification (N))); 4864 end if; 4865 4866 else 4867 -- The call goes at the start of the statement sequence after the 4868 -- start of exception range label if one is present. 4869 4870 if Present (Handled_Statement_Sequence (N)) then 4871 Stmt := First (Statements (Handled_Statement_Sequence (N))); 4872 4873 -- A special case, skip exception range label if one is present 4874 -- (from front end zcx processing). 4875 4876 if Nkind (Stmt) = N_Label and then Exception_Junk (Stmt) then 4877 Next (Stmt); 4878 end if; 4879 4880 -- Another special case, if the first statement is a block from 4881 -- optimization of a local raise to a goto, then the call goes 4882 -- inside this block. 4883 4884 if Nkind (Stmt) = N_Block_Statement 4885 and then Exception_Junk (Stmt) 4886 then 4887 Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); 4888 end if; 4889 4890 -- Insertion point is after any exception label pushes, since we 4891 -- want it covered by any local handlers. 4892 4893 while Nkind (Stmt) in N_Push_xxx_Label loop 4894 Next (Stmt); 4895 end loop; 4896 4897 -- Now we have the proper insertion point 4898 4899 Insert_Before (Stmt, Call); 4900 4901 else 4902 Set_Handled_Statement_Sequence (N, 4903 Make_Handled_Sequence_Of_Statements (Loc, 4904 Statements => New_List (Call))); 4905 end if; 4906 end if; 4907 4908 Analyze (Call); 4909 4910 if Legacy_Elaboration_Checks then 4911 Check_Task_Activation (N); 4912 end if; 4913 end Build_Task_Activation_Call; 4914 4915 ------------------------------- 4916 -- Build_Task_Allocate_Block -- 4917 ------------------------------- 4918 4919 procedure Build_Task_Allocate_Block 4920 (Actions : List_Id; 4921 N : Node_Id; 4922 Args : List_Id) 4923 is 4924 T : constant Entity_Id := Entity (Expression (N)); 4925 Init : constant Entity_Id := Base_Init_Proc (T); 4926 Loc : constant Source_Ptr := Sloc (N); 4927 Chain : constant Entity_Id := 4928 Make_Defining_Identifier (Loc, Name_uChain); 4929 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 4930 Block : Node_Id; 4931 4932 begin 4933 Block := 4934 Make_Block_Statement (Loc, 4935 Identifier => New_Occurrence_Of (Blkent, Loc), 4936 Declarations => New_List ( 4937 4938 -- _Chain : Activation_Chain; 4939 4940 Make_Object_Declaration (Loc, 4941 Defining_Identifier => Chain, 4942 Aliased_Present => True, 4943 Object_Definition => 4944 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 4945 4946 Handled_Statement_Sequence => 4947 Make_Handled_Sequence_Of_Statements (Loc, 4948 4949 Statements => New_List ( 4950 4951 -- Init (Args); 4952 4953 Make_Procedure_Call_Statement (Loc, 4954 Name => New_Occurrence_Of (Init, Loc), 4955 Parameter_Associations => Args), 4956 4957 -- Activate_Tasks (_Chain); 4958 4959 Make_Procedure_Call_Statement (Loc, 4960 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 4961 Parameter_Associations => New_List ( 4962 Make_Attribute_Reference (Loc, 4963 Prefix => New_Occurrence_Of (Chain, Loc), 4964 Attribute_Name => Name_Unchecked_Access))))), 4965 4966 Has_Created_Identifier => True, 4967 Is_Task_Allocation_Block => True); 4968 4969 Append_To (Actions, 4970 Make_Implicit_Label_Declaration (Loc, 4971 Defining_Identifier => Blkent, 4972 Label_Construct => Block)); 4973 4974 Append_To (Actions, Block); 4975 4976 Set_Activation_Chain_Entity (Block, Chain); 4977 end Build_Task_Allocate_Block; 4978 4979 ----------------------------------------------- 4980 -- Build_Task_Allocate_Block_With_Init_Stmts -- 4981 ----------------------------------------------- 4982 4983 procedure Build_Task_Allocate_Block_With_Init_Stmts 4984 (Actions : List_Id; 4985 N : Node_Id; 4986 Init_Stmts : List_Id) 4987 is 4988 Loc : constant Source_Ptr := Sloc (N); 4989 Chain : constant Entity_Id := 4990 Make_Defining_Identifier (Loc, Name_uChain); 4991 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 4992 Block : Node_Id; 4993 4994 begin 4995 Append_To (Init_Stmts, 4996 Make_Procedure_Call_Statement (Loc, 4997 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 4998 Parameter_Associations => New_List ( 4999 Make_Attribute_Reference (Loc, 5000 Prefix => New_Occurrence_Of (Chain, Loc), 5001 Attribute_Name => Name_Unchecked_Access)))); 5002 5003 Block := 5004 Make_Block_Statement (Loc, 5005 Identifier => New_Occurrence_Of (Blkent, Loc), 5006 Declarations => New_List ( 5007 5008 -- _Chain : Activation_Chain; 5009 5010 Make_Object_Declaration (Loc, 5011 Defining_Identifier => Chain, 5012 Aliased_Present => True, 5013 Object_Definition => 5014 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5015 5016 Handled_Statement_Sequence => 5017 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts), 5018 5019 Has_Created_Identifier => True, 5020 Is_Task_Allocation_Block => True); 5021 5022 Append_To (Actions, 5023 Make_Implicit_Label_Declaration (Loc, 5024 Defining_Identifier => Blkent, 5025 Label_Construct => Block)); 5026 5027 Append_To (Actions, Block); 5028 5029 Set_Activation_Chain_Entity (Block, Chain); 5030 end Build_Task_Allocate_Block_With_Init_Stmts; 5031 5032 ----------------------------------- 5033 -- Build_Task_Proc_Specification -- 5034 ----------------------------------- 5035 5036 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is 5037 Loc : constant Source_Ptr := Sloc (T); 5038 Spec_Id : Entity_Id; 5039 5040 begin 5041 -- Case of explicit task type, suffix TB 5042 5043 if Comes_From_Source (T) then 5044 Spec_Id := 5045 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB")); 5046 5047 -- Case of anonymous task type, suffix B 5048 5049 else 5050 Spec_Id := 5051 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B')); 5052 end if; 5053 5054 Set_Is_Internal (Spec_Id); 5055 5056 -- Associate the procedure with the task, if this is the declaration 5057 -- (and not the body) of the procedure. 5058 5059 if No (Task_Body_Procedure (T)) then 5060 Set_Task_Body_Procedure (T, Spec_Id); 5061 end if; 5062 5063 return 5064 Make_Procedure_Specification (Loc, 5065 Defining_Unit_Name => Spec_Id, 5066 Parameter_Specifications => New_List ( 5067 Make_Parameter_Specification (Loc, 5068 Defining_Identifier => 5069 Make_Defining_Identifier (Loc, Name_uTask), 5070 Parameter_Type => 5071 Make_Access_Definition (Loc, 5072 Subtype_Mark => 5073 New_Occurrence_Of (Corresponding_Record_Type (T), Loc))))); 5074 end Build_Task_Proc_Specification; 5075 5076 --------------------------------------- 5077 -- Build_Unprotected_Subprogram_Body -- 5078 --------------------------------------- 5079 5080 function Build_Unprotected_Subprogram_Body 5081 (N : Node_Id; 5082 Pid : Node_Id) return Node_Id 5083 is 5084 Decls : constant List_Id := Declarations (N); 5085 5086 begin 5087 -- Add renamings for the Protection object, discriminals, privals, and 5088 -- the entry index constant for use by debugger. 5089 5090 Debug_Private_Data_Declarations (Decls); 5091 5092 -- Make an unprotected version of the subprogram for use within the same 5093 -- object, with a new name and an additional parameter representing the 5094 -- object. 5095 5096 return 5097 Make_Subprogram_Body (Sloc (N), 5098 Specification => 5099 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), 5100 Declarations => Decls, 5101 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 5102 end Build_Unprotected_Subprogram_Body; 5103 5104 ---------------------------- 5105 -- Collect_Entry_Families -- 5106 ---------------------------- 5107 5108 procedure Collect_Entry_Families 5109 (Loc : Source_Ptr; 5110 Cdecls : List_Id; 5111 Current_Node : in out Node_Id; 5112 Conctyp : Entity_Id) 5113 is 5114 Efam : Entity_Id; 5115 Efam_Decl : Node_Id; 5116 Efam_Type : Entity_Id; 5117 5118 begin 5119 Efam := First_Entity (Conctyp); 5120 while Present (Efam) loop 5121 if Ekind (Efam) = E_Entry_Family then 5122 Efam_Type := Make_Temporary (Loc, 'F'); 5123 5124 declare 5125 Bas : Entity_Id := 5126 Base_Type 5127 (Etype (Discrete_Subtype_Definition (Parent (Efam)))); 5128 5129 Bas_Decl : Node_Id := Empty; 5130 Lo, Hi : Node_Id; 5131 5132 begin 5133 Get_Index_Bounds 5134 (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi); 5135 5136 if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then 5137 Bas := Make_Temporary (Loc, 'B'); 5138 5139 Bas_Decl := 5140 Make_Subtype_Declaration (Loc, 5141 Defining_Identifier => Bas, 5142 Subtype_Indication => 5143 Make_Subtype_Indication (Loc, 5144 Subtype_Mark => 5145 New_Occurrence_Of (Standard_Integer, Loc), 5146 Constraint => 5147 Make_Range_Constraint (Loc, 5148 Range_Expression => Make_Range (Loc, 5149 Make_Integer_Literal 5150 (Loc, -Entry_Family_Bound), 5151 Make_Integer_Literal 5152 (Loc, Entry_Family_Bound - 1))))); 5153 5154 Insert_After (Current_Node, Bas_Decl); 5155 Current_Node := Bas_Decl; 5156 Analyze (Bas_Decl); 5157 end if; 5158 5159 Efam_Decl := 5160 Make_Full_Type_Declaration (Loc, 5161 Defining_Identifier => Efam_Type, 5162 Type_Definition => 5163 Make_Unconstrained_Array_Definition (Loc, 5164 Subtype_Marks => 5165 (New_List (New_Occurrence_Of (Bas, Loc))), 5166 5167 Component_Definition => 5168 Make_Component_Definition (Loc, 5169 Aliased_Present => False, 5170 Subtype_Indication => 5171 New_Occurrence_Of (Standard_Character, Loc)))); 5172 end; 5173 5174 Insert_After (Current_Node, Efam_Decl); 5175 Current_Node := Efam_Decl; 5176 Analyze (Efam_Decl); 5177 5178 Append_To (Cdecls, 5179 Make_Component_Declaration (Loc, 5180 Defining_Identifier => 5181 Make_Defining_Identifier (Loc, Chars (Efam)), 5182 5183 Component_Definition => 5184 Make_Component_Definition (Loc, 5185 Aliased_Present => False, 5186 Subtype_Indication => 5187 Make_Subtype_Indication (Loc, 5188 Subtype_Mark => 5189 New_Occurrence_Of (Efam_Type, Loc), 5190 5191 Constraint => 5192 Make_Index_Or_Discriminant_Constraint (Loc, 5193 Constraints => New_List ( 5194 New_Occurrence_Of 5195 (Etype (Discrete_Subtype_Definition 5196 (Parent (Efam))), Loc))))))); 5197 5198 end if; 5199 5200 Next_Entity (Efam); 5201 end loop; 5202 end Collect_Entry_Families; 5203 5204 ----------------------- 5205 -- Concurrent_Object -- 5206 ----------------------- 5207 5208 function Concurrent_Object 5209 (Spec_Id : Entity_Id; 5210 Conc_Typ : Entity_Id) return Entity_Id 5211 is 5212 begin 5213 -- Parameter _O or _object 5214 5215 if Is_Protected_Type (Conc_Typ) then 5216 return First_Formal (Protected_Body_Subprogram (Spec_Id)); 5217 5218 -- Parameter _task 5219 5220 else 5221 pragma Assert (Is_Task_Type (Conc_Typ)); 5222 return First_Formal (Task_Body_Procedure (Conc_Typ)); 5223 end if; 5224 end Concurrent_Object; 5225 5226 ---------------------- 5227 -- Copy_Result_Type -- 5228 ---------------------- 5229 5230 function Copy_Result_Type (Res : Node_Id) return Node_Id is 5231 New_Res : constant Node_Id := New_Copy_Tree (Res); 5232 Par_Spec : Node_Id; 5233 Formal : Entity_Id; 5234 5235 begin 5236 -- If the result type is an access_to_subprogram, we must create new 5237 -- entities for its spec. 5238 5239 if Nkind (New_Res) = N_Access_Definition 5240 and then Present (Access_To_Subprogram_Definition (New_Res)) 5241 then 5242 -- Provide new entities for the formals 5243 5244 Par_Spec := First (Parameter_Specifications 5245 (Access_To_Subprogram_Definition (New_Res))); 5246 while Present (Par_Spec) loop 5247 Formal := Defining_Identifier (Par_Spec); 5248 Set_Defining_Identifier (Par_Spec, 5249 Make_Defining_Identifier (Sloc (Formal), Chars (Formal))); 5250 Next (Par_Spec); 5251 end loop; 5252 end if; 5253 5254 return New_Res; 5255 end Copy_Result_Type; 5256 5257 -------------------- 5258 -- Concurrent_Ref -- 5259 -------------------- 5260 5261 -- The expression returned for a reference to a concurrent object has the 5262 -- form: 5263 5264 -- taskV!(name)._Task_Id 5265 5266 -- for a task, and 5267 5268 -- objectV!(name)._Object 5269 5270 -- for a protected object. For the case of an access to a concurrent 5271 -- object, there is an extra explicit dereference: 5272 5273 -- taskV!(name.all)._Task_Id 5274 -- objectV!(name.all)._Object 5275 5276 -- here taskV and objectV are the types for the associated records, which 5277 -- contain the required _Task_Id and _Object fields for tasks and protected 5278 -- objects, respectively. 5279 5280 -- For the case of a task type name, the expression is 5281 5282 -- Self; 5283 5284 -- i.e. a call to the Self function which returns precisely this Task_Id 5285 5286 -- For the case of a protected type name, the expression is 5287 5288 -- objectR 5289 5290 -- which is a renaming of the _object field of the current object 5291 -- record, passed into protected operations as a parameter. 5292 5293 function Concurrent_Ref (N : Node_Id) return Node_Id is 5294 Loc : constant Source_Ptr := Sloc (N); 5295 Ntyp : constant Entity_Id := Etype (N); 5296 Dtyp : Entity_Id; 5297 Sel : Name_Id; 5298 5299 function Is_Current_Task (T : Entity_Id) return Boolean; 5300 -- Check whether the reference is to the immediately enclosing task 5301 -- type, or to an outer one (rare but legal). 5302 5303 --------------------- 5304 -- Is_Current_Task -- 5305 --------------------- 5306 5307 function Is_Current_Task (T : Entity_Id) return Boolean is 5308 Scop : Entity_Id; 5309 5310 begin 5311 Scop := Current_Scope; 5312 while Present (Scop) and then Scop /= Standard_Standard loop 5313 if Scop = T then 5314 return True; 5315 5316 elsif Is_Task_Type (Scop) then 5317 return False; 5318 5319 -- If this is a procedure nested within the task type, we must 5320 -- assume that it can be called from an inner task, and therefore 5321 -- cannot treat it as a local reference. 5322 5323 elsif Is_Overloadable (Scop) and then In_Open_Scopes (T) then 5324 return False; 5325 5326 else 5327 Scop := Scope (Scop); 5328 end if; 5329 end loop; 5330 5331 -- We know that we are within the task body, so should have found it 5332 -- in scope. 5333 5334 raise Program_Error; 5335 end Is_Current_Task; 5336 5337 -- Start of processing for Concurrent_Ref 5338 5339 begin 5340 if Is_Access_Type (Ntyp) then 5341 Dtyp := Designated_Type (Ntyp); 5342 5343 if Is_Protected_Type (Dtyp) then 5344 Sel := Name_uObject; 5345 else 5346 Sel := Name_uTask_Id; 5347 end if; 5348 5349 return 5350 Make_Selected_Component (Loc, 5351 Prefix => 5352 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp), 5353 Make_Explicit_Dereference (Loc, N)), 5354 Selector_Name => Make_Identifier (Loc, Sel)); 5355 5356 elsif Is_Entity_Name (N) and then Is_Concurrent_Type (Entity (N)) then 5357 if Is_Task_Type (Entity (N)) then 5358 5359 if Is_Current_Task (Entity (N)) then 5360 return 5361 Make_Function_Call (Loc, 5362 Name => New_Occurrence_Of (RTE (RE_Self), Loc)); 5363 5364 else 5365 declare 5366 Decl : Node_Id; 5367 T_Self : constant Entity_Id := Make_Temporary (Loc, 'T'); 5368 T_Body : constant Node_Id := 5369 Parent (Corresponding_Body (Parent (Entity (N)))); 5370 5371 begin 5372 Decl := 5373 Make_Object_Declaration (Loc, 5374 Defining_Identifier => T_Self, 5375 Object_Definition => 5376 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 5377 Expression => 5378 Make_Function_Call (Loc, 5379 Name => New_Occurrence_Of (RTE (RE_Self), Loc))); 5380 Prepend (Decl, Declarations (T_Body)); 5381 Analyze (Decl); 5382 Set_Scope (T_Self, Entity (N)); 5383 return New_Occurrence_Of (T_Self, Loc); 5384 end; 5385 end if; 5386 5387 else 5388 pragma Assert (Is_Protected_Type (Entity (N))); 5389 5390 return 5391 New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc); 5392 end if; 5393 5394 else 5395 if Is_Protected_Type (Ntyp) then 5396 Sel := Name_uObject; 5397 elsif Is_Task_Type (Ntyp) then 5398 Sel := Name_uTask_Id; 5399 else 5400 raise Program_Error; 5401 end if; 5402 5403 return 5404 Make_Selected_Component (Loc, 5405 Prefix => 5406 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp), 5407 New_Copy_Tree (N)), 5408 Selector_Name => Make_Identifier (Loc, Sel)); 5409 end if; 5410 end Concurrent_Ref; 5411 5412 ------------------------ 5413 -- Convert_Concurrent -- 5414 ------------------------ 5415 5416 function Convert_Concurrent 5417 (N : Node_Id; 5418 Typ : Entity_Id) return Node_Id 5419 is 5420 begin 5421 if not Is_Concurrent_Type (Typ) then 5422 return N; 5423 else 5424 return 5425 Unchecked_Convert_To 5426 (Corresponding_Record_Type (Typ), New_Copy_Tree (N)); 5427 end if; 5428 end Convert_Concurrent; 5429 5430 ------------------------------------- 5431 -- Create_Secondary_Stack_For_Task -- 5432 ------------------------------------- 5433 5434 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean is 5435 begin 5436 return 5437 (Restriction_Active (No_Implicit_Heap_Allocations) 5438 or else Restriction_Active (No_Implicit_Task_Allocations)) 5439 and then not Restriction_Active (No_Secondary_Stack) 5440 and then Has_Rep_Pragma 5441 (T, Name_Secondary_Stack_Size, Check_Parents => False); 5442 end Create_Secondary_Stack_For_Task; 5443 5444 ------------------------------------- 5445 -- Debug_Private_Data_Declarations -- 5446 ------------------------------------- 5447 5448 procedure Debug_Private_Data_Declarations (Decls : List_Id) is 5449 Debug_Nod : Node_Id; 5450 Decl : Node_Id; 5451 5452 begin 5453 Decl := First (Decls); 5454 while Present (Decl) and then not Comes_From_Source (Decl) loop 5455 5456 -- Declaration for concurrent entity _object and its access type, 5457 -- along with the entry index subtype: 5458 -- type prot_typVP is access prot_typV; 5459 -- _object : prot_typVP := prot_typV (_O); 5460 -- subtype Jnn is <Type of Index> range Low .. High; 5461 5462 if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then 5463 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5464 5465 -- Declaration for the Protection object, discriminals, privals, and 5466 -- entry index constant: 5467 -- conc_typR : protection_typ renames _object._object; 5468 -- discr_nameD : discr_typ renames _object.discr_name; 5469 -- discr_nameD : discr_typ renames _task.discr_name; 5470 -- prival_name : comp_typ renames _object.comp_name; 5471 -- J : constant Jnn := 5472 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First)); 5473 5474 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 5475 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5476 Debug_Nod := Debug_Renaming_Declaration (Decl); 5477 5478 if Present (Debug_Nod) then 5479 Insert_After (Decl, Debug_Nod); 5480 end if; 5481 end if; 5482 5483 Next (Decl); 5484 end loop; 5485 end Debug_Private_Data_Declarations; 5486 5487 ------------------------------ 5488 -- Ensure_Statement_Present -- 5489 ------------------------------ 5490 5491 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is 5492 Stmt : Node_Id; 5493 5494 begin 5495 if Opt.Suppress_Control_Flow_Optimizations 5496 and then Is_Empty_List (Statements (Alt)) 5497 then 5498 Stmt := Make_Null_Statement (Loc); 5499 5500 -- Mark NULL statement as coming from source so that it is not 5501 -- eliminated by GIGI. 5502 5503 -- Another covert channel. If this is a requirement, it must be 5504 -- documented in sinfo/einfo ??? 5505 5506 Set_Comes_From_Source (Stmt, True); 5507 5508 Set_Statements (Alt, New_List (Stmt)); 5509 end if; 5510 end Ensure_Statement_Present; 5511 5512 ---------------------------- 5513 -- Entry_Index_Expression -- 5514 ---------------------------- 5515 5516 function Entry_Index_Expression 5517 (Sloc : Source_Ptr; 5518 Ent : Entity_Id; 5519 Index : Node_Id; 5520 Ttyp : Entity_Id) return Node_Id 5521 is 5522 Expr : Node_Id; 5523 Num : Node_Id; 5524 Lo : Node_Id; 5525 Hi : Node_Id; 5526 Prev : Entity_Id; 5527 S : Node_Id; 5528 5529 begin 5530 -- The queues of entries and entry families appear in textual order in 5531 -- the associated record. The entry index is computed as the sum of the 5532 -- number of queues for all entries that precede the designated one, to 5533 -- which is added the index expression, if this expression denotes a 5534 -- member of a family. 5535 5536 -- The following is a place holder for the count of simple entries 5537 5538 Num := Make_Integer_Literal (Sloc, 1); 5539 5540 -- We construct an expression which is a series of addition operations. 5541 -- The first operand is the number of single entries that precede this 5542 -- one, the second operand is the index value relative to the start of 5543 -- the referenced family, and the remaining operands are the lengths of 5544 -- the entry families that precede this entry, i.e. the constructed 5545 -- expression is: 5546 5547 -- number_simple_entries + 5548 -- (s'pos (index-value) - s'pos (family'first)) + 1 + 5549 -- family'length + ... 5550 5551 -- where index-value is the given index value, and s is the index 5552 -- subtype (we have to use pos because the subtype might be an 5553 -- enumeration type preventing direct subtraction). Note that the task 5554 -- entry array is one-indexed. 5555 5556 -- The upper bound of the entry family may be a discriminant, so we 5557 -- retrieve the lower bound explicitly to compute offset, rather than 5558 -- using the index subtype which may mention a discriminant. 5559 5560 if Present (Index) then 5561 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); 5562 5563 Expr := 5564 Make_Op_Add (Sloc, 5565 Left_Opnd => Num, 5566 Right_Opnd => 5567 Family_Offset 5568 (Sloc, 5569 Make_Attribute_Reference (Sloc, 5570 Attribute_Name => Name_Pos, 5571 Prefix => New_Occurrence_Of (Base_Type (S), Sloc), 5572 Expressions => New_List (Relocate_Node (Index))), 5573 Type_Low_Bound (S), 5574 Ttyp, 5575 False)); 5576 else 5577 Expr := Num; 5578 end if; 5579 5580 -- Now add lengths of preceding entries and entry families 5581 5582 Prev := First_Entity (Ttyp); 5583 while Chars (Prev) /= Chars (Ent) 5584 or else (Ekind (Prev) /= Ekind (Ent)) 5585 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 5586 loop 5587 if Ekind (Prev) = E_Entry then 5588 Set_Intval (Num, Intval (Num) + 1); 5589 5590 elsif Ekind (Prev) = E_Entry_Family then 5591 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 5592 Lo := Type_Low_Bound (S); 5593 Hi := Type_High_Bound (S); 5594 5595 Expr := 5596 Make_Op_Add (Sloc, 5597 Left_Opnd => Expr, 5598 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False)); 5599 5600 -- Other components are anonymous types to be ignored 5601 5602 else 5603 null; 5604 end if; 5605 5606 Next_Entity (Prev); 5607 end loop; 5608 5609 return Expr; 5610 end Entry_Index_Expression; 5611 5612 --------------------------- 5613 -- Establish_Task_Master -- 5614 --------------------------- 5615 5616 procedure Establish_Task_Master (N : Node_Id) is 5617 Call : Node_Id; 5618 5619 begin 5620 if Restriction_Active (No_Task_Hierarchy) = False then 5621 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); 5622 5623 -- The block may have no declarations (and nevertheless be a task 5624 -- master) if it contains a call that may return an object that 5625 -- contains tasks. 5626 5627 if No (Declarations (N)) then 5628 Set_Declarations (N, New_List (Call)); 5629 else 5630 Prepend_To (Declarations (N), Call); 5631 end if; 5632 5633 Analyze (Call); 5634 end if; 5635 end Establish_Task_Master; 5636 5637 -------------------------------- 5638 -- Expand_Accept_Declarations -- 5639 -------------------------------- 5640 5641 -- Part of the expansion of an accept statement involves the creation of 5642 -- a declaration that can be referenced from the statement sequence of 5643 -- the accept: 5644 5645 -- Ann : Address; 5646 5647 -- This declaration is inserted immediately before the accept statement 5648 -- and it is important that it be inserted before the statements of the 5649 -- statement sequence are analyzed. Thus it would be too late to create 5650 -- this declaration in the Expand_N_Accept_Statement routine, which is 5651 -- why there is a separate procedure to be called directly from Sem_Ch9. 5652 5653 -- Ann is used to hold the address of the record containing the parameters 5654 -- (see Expand_N_Entry_Call for more details on how this record is built). 5655 -- References to the parameters do an unchecked conversion of this address 5656 -- to a pointer to the required record type, and then access the field that 5657 -- holds the value of the required parameter. The entity for the address 5658 -- variable is held as the top stack element (i.e. the last element) of the 5659 -- Accept_Address stack in the corresponding entry entity, and this element 5660 -- must be set in place before the statements are processed. 5661 5662 -- The above description applies to the case of a stand alone accept 5663 -- statement, i.e. one not appearing as part of a select alternative. 5664 5665 -- For the case of an accept that appears as part of a select alternative 5666 -- of a selective accept, we must still create the declaration right away, 5667 -- since Ann is needed immediately, but there is an important difference: 5668 5669 -- The declaration is inserted before the selective accept, not before 5670 -- the accept statement (which is not part of a list anyway, and so would 5671 -- not accommodate inserted declarations) 5672 5673 -- We only need one address variable for the entire selective accept. So 5674 -- the Ann declaration is created only for the first accept alternative, 5675 -- and subsequent accept alternatives reference the same Ann variable. 5676 5677 -- We can distinguish the two cases by seeing whether the accept statement 5678 -- is part of a list. If not, then it must be in an accept alternative. 5679 5680 -- To expand the requeue statement, a label is provided at the end of the 5681 -- accept statement or alternative of which it is a part, so that the 5682 -- statement can be skipped after the requeue is complete. This label is 5683 -- created here rather than during the expansion of the accept statement, 5684 -- because it will be needed by any requeue statements within the accept, 5685 -- which are expanded before the accept. 5686 5687 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is 5688 Loc : constant Source_Ptr := Sloc (N); 5689 Stats : constant Node_Id := Handled_Statement_Sequence (N); 5690 Ann : Entity_Id := Empty; 5691 Adecl : Node_Id; 5692 Lab : Node_Id; 5693 Ldecl : Node_Id; 5694 Ldecl2 : Node_Id; 5695 5696 begin 5697 if Expander_Active then 5698 5699 -- If we have no handled statement sequence, we may need to build 5700 -- a dummy sequence consisting of a null statement. This can be 5701 -- skipped if the trivial accept optimization is permitted. 5702 5703 if not Trivial_Accept_OK 5704 and then (No (Stats) or else Null_Statements (Statements (Stats))) 5705 then 5706 Set_Handled_Statement_Sequence (N, 5707 Make_Handled_Sequence_Of_Statements (Loc, 5708 Statements => New_List (Make_Null_Statement (Loc)))); 5709 end if; 5710 5711 -- Create and declare two labels to be placed at the end of the 5712 -- accept statement. The first label is used to allow requeues to 5713 -- skip the remainder of entry processing. The second label is used 5714 -- to skip the remainder of entry processing if the rendezvous 5715 -- completes in the middle of the accept body. 5716 5717 if Present (Handled_Statement_Sequence (N)) then 5718 declare 5719 Ent : Entity_Id; 5720 5721 begin 5722 Ent := Make_Temporary (Loc, 'L'); 5723 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 5724 Ldecl := 5725 Make_Implicit_Label_Declaration (Loc, 5726 Defining_Identifier => Ent, 5727 Label_Construct => Lab); 5728 Append (Lab, Statements (Handled_Statement_Sequence (N))); 5729 5730 Ent := Make_Temporary (Loc, 'L'); 5731 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 5732 Ldecl2 := 5733 Make_Implicit_Label_Declaration (Loc, 5734 Defining_Identifier => Ent, 5735 Label_Construct => Lab); 5736 Append (Lab, Statements (Handled_Statement_Sequence (N))); 5737 end; 5738 5739 else 5740 Ldecl := Empty; 5741 Ldecl2 := Empty; 5742 end if; 5743 5744 -- Case of stand alone accept statement 5745 5746 if Is_List_Member (N) then 5747 5748 if Present (Handled_Statement_Sequence (N)) then 5749 Ann := Make_Temporary (Loc, 'A'); 5750 5751 Adecl := 5752 Make_Object_Declaration (Loc, 5753 Defining_Identifier => Ann, 5754 Object_Definition => 5755 New_Occurrence_Of (RTE (RE_Address), Loc)); 5756 5757 Insert_Before_And_Analyze (N, Adecl); 5758 Insert_Before_And_Analyze (N, Ldecl); 5759 Insert_Before_And_Analyze (N, Ldecl2); 5760 end if; 5761 5762 -- Case of accept statement which is in an accept alternative 5763 5764 else 5765 declare 5766 Acc_Alt : constant Node_Id := Parent (N); 5767 Sel_Acc : constant Node_Id := Parent (Acc_Alt); 5768 Alt : Node_Id; 5769 5770 begin 5771 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative); 5772 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept); 5773 5774 -- ??? Consider a single label for select statements 5775 5776 if Present (Handled_Statement_Sequence (N)) then 5777 Prepend (Ldecl2, 5778 Statements (Handled_Statement_Sequence (N))); 5779 Analyze (Ldecl2); 5780 5781 Prepend (Ldecl, 5782 Statements (Handled_Statement_Sequence (N))); 5783 Analyze (Ldecl); 5784 end if; 5785 5786 -- Find first accept alternative of the selective accept. A 5787 -- valid selective accept must have at least one accept in it. 5788 5789 Alt := First (Select_Alternatives (Sel_Acc)); 5790 5791 while Nkind (Alt) /= N_Accept_Alternative loop 5792 Next (Alt); 5793 end loop; 5794 5795 -- If this is the first accept statement, then we have to 5796 -- create the Ann variable, as for the stand alone case, except 5797 -- that it is inserted before the selective accept. Similarly, 5798 -- a label for requeue expansion must be declared. 5799 5800 if N = Accept_Statement (Alt) then 5801 Ann := Make_Temporary (Loc, 'A'); 5802 Adecl := 5803 Make_Object_Declaration (Loc, 5804 Defining_Identifier => Ann, 5805 Object_Definition => 5806 New_Occurrence_Of (RTE (RE_Address), Loc)); 5807 5808 Insert_Before_And_Analyze (Sel_Acc, Adecl); 5809 5810 -- If this is not the first accept statement, then find the Ann 5811 -- variable allocated by the first accept and use it. 5812 5813 else 5814 Ann := 5815 Node (Last_Elmt (Accept_Address 5816 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))))); 5817 end if; 5818 end; 5819 end if; 5820 5821 -- Merge here with Ann either created or referenced, and Adecl 5822 -- pointing to the corresponding declaration. Remaining processing 5823 -- is the same for the two cases. 5824 5825 if Present (Ann) then 5826 Append_Elmt (Ann, Accept_Address (Ent)); 5827 Set_Debug_Info_Needed (Ann); 5828 end if; 5829 5830 -- Create renaming declarations for the entry formals. Each reference 5831 -- to a formal becomes a dereference of a component of the parameter 5832 -- block, whose address is held in Ann. These declarations are 5833 -- eventually inserted into the accept block, and analyzed there so 5834 -- that they have the proper scope for gdb and do not conflict with 5835 -- other declarations. 5836 5837 if Present (Parameter_Specifications (N)) 5838 and then Present (Handled_Statement_Sequence (N)) 5839 then 5840 declare 5841 Comp : Entity_Id; 5842 Decl : Node_Id; 5843 Formal : Entity_Id; 5844 New_F : Entity_Id; 5845 Renamed_Formal : Node_Id; 5846 5847 begin 5848 Push_Scope (Ent); 5849 Formal := First_Formal (Ent); 5850 5851 while Present (Formal) loop 5852 Comp := Entry_Component (Formal); 5853 New_F := Make_Defining_Identifier (Loc, Chars (Formal)); 5854 5855 Set_Etype (New_F, Etype (Formal)); 5856 Set_Scope (New_F, Ent); 5857 5858 -- Now we set debug info needed on New_F even though it does 5859 -- not come from source, so that the debugger will get the 5860 -- right information for these generated names. 5861 5862 Set_Debug_Info_Needed (New_F); 5863 5864 if Ekind (Formal) = E_In_Parameter then 5865 Set_Ekind (New_F, E_Constant); 5866 else 5867 Set_Ekind (New_F, E_Variable); 5868 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 5869 end if; 5870 5871 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 5872 5873 Renamed_Formal := 5874 Make_Selected_Component (Loc, 5875 Prefix => 5876 Unchecked_Convert_To ( 5877 Entry_Parameters_Type (Ent), 5878 New_Occurrence_Of (Ann, Loc)), 5879 Selector_Name => 5880 New_Occurrence_Of (Comp, Loc)); 5881 5882 Decl := 5883 Build_Renamed_Formal_Declaration 5884 (New_F, Formal, Comp, Renamed_Formal); 5885 5886 if No (Declarations (N)) then 5887 Set_Declarations (N, New_List); 5888 end if; 5889 5890 Append (Decl, Declarations (N)); 5891 Set_Renamed_Object (Formal, New_F); 5892 Next_Formal (Formal); 5893 end loop; 5894 5895 End_Scope; 5896 end; 5897 end if; 5898 end if; 5899 end Expand_Accept_Declarations; 5900 5901 --------------------------------------------- 5902 -- Expand_Access_Protected_Subprogram_Type -- 5903 --------------------------------------------- 5904 5905 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is 5906 Loc : constant Source_Ptr := Sloc (N); 5907 T : constant Entity_Id := Defining_Identifier (N); 5908 D_T : constant Entity_Id := Designated_Type (T); 5909 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D'); 5910 E_T : constant Entity_Id := Make_Temporary (Loc, 'E'); 5911 P_List : constant List_Id := 5912 Build_Protected_Spec (N, RTE (RE_Address), D_T, False); 5913 5914 Comps : List_Id; 5915 Decl1 : Node_Id; 5916 Decl2 : Node_Id; 5917 Def1 : Node_Id; 5918 5919 begin 5920 -- Create access to subprogram with full signature 5921 5922 if Etype (D_T) /= Standard_Void_Type then 5923 Def1 := 5924 Make_Access_Function_Definition (Loc, 5925 Parameter_Specifications => P_List, 5926 Result_Definition => 5927 Copy_Result_Type (Result_Definition (Type_Definition (N)))); 5928 5929 else 5930 Def1 := 5931 Make_Access_Procedure_Definition (Loc, 5932 Parameter_Specifications => P_List); 5933 end if; 5934 5935 Decl1 := 5936 Make_Full_Type_Declaration (Loc, 5937 Defining_Identifier => D_T2, 5938 Type_Definition => Def1); 5939 5940 -- Declare the new types before the original one since the latter will 5941 -- refer to them through the Equivalent_Type slot. 5942 5943 Insert_Before_And_Analyze (N, Decl1); 5944 5945 -- Associate the access to subprogram with its original access to 5946 -- protected subprogram type. Needed by the backend to know that this 5947 -- type corresponds with an access to protected subprogram type. 5948 5949 Set_Original_Access_Type (D_T2, T); 5950 5951 -- Create Equivalent_Type, a record with two components for an access to 5952 -- object and an access to subprogram. 5953 5954 Comps := New_List ( 5955 Make_Component_Declaration (Loc, 5956 Defining_Identifier => Make_Temporary (Loc, 'P'), 5957 Component_Definition => 5958 Make_Component_Definition (Loc, 5959 Aliased_Present => False, 5960 Subtype_Indication => 5961 New_Occurrence_Of (RTE (RE_Address), Loc))), 5962 5963 Make_Component_Declaration (Loc, 5964 Defining_Identifier => Make_Temporary (Loc, 'S'), 5965 Component_Definition => 5966 Make_Component_Definition (Loc, 5967 Aliased_Present => False, 5968 Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); 5969 5970 Decl2 := 5971 Make_Full_Type_Declaration (Loc, 5972 Defining_Identifier => E_T, 5973 Type_Definition => 5974 Make_Record_Definition (Loc, 5975 Component_List => 5976 Make_Component_List (Loc, Component_Items => Comps))); 5977 5978 Insert_Before_And_Analyze (N, Decl2); 5979 Set_Equivalent_Type (T, E_T); 5980 end Expand_Access_Protected_Subprogram_Type; 5981 5982 -------------------------- 5983 -- Expand_Entry_Barrier -- 5984 -------------------------- 5985 5986 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is 5987 Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N)); 5988 Prot : constant Entity_Id := Scope (Ent); 5989 Spec_Decl : constant Node_Id := Parent (Prot); 5990 5991 Func_Id : Entity_Id := Empty; 5992 -- The entity of the barrier function 5993 5994 function Is_Global_Entity (N : Node_Id) return Traverse_Result; 5995 -- Check whether entity in Barrier is external to protected type. 5996 -- If so, barrier may not be properly synchronized. 5997 5998 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result; 5999 -- Check whether N follows the Pure_Barriers restriction. Return OK if 6000 -- so. 6001 6002 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean; 6003 -- Check whether entity name N denotes a component of the protected 6004 -- object. This is used to check the Simple_Barrier restriction. 6005 6006 ---------------------- 6007 -- Is_Global_Entity -- 6008 ---------------------- 6009 6010 function Is_Global_Entity (N : Node_Id) return Traverse_Result is 6011 E : Entity_Id; 6012 S : Entity_Id; 6013 6014 begin 6015 if Is_Entity_Name (N) and then Present (Entity (N)) then 6016 E := Entity (N); 6017 S := Scope (E); 6018 6019 if Ekind (E) = E_Variable then 6020 6021 -- If the variable is local to the barrier function generated 6022 -- during expansion, it is ok. If expansion is not performed, 6023 -- then Func is Empty so this test cannot succeed. 6024 6025 if Scope (E) = Func_Id then 6026 null; 6027 6028 -- A protected call from a barrier to another object is ok 6029 6030 elsif Ekind (Etype (E)) = E_Protected_Type then 6031 null; 6032 6033 -- If the variable is within the package body we consider 6034 -- this safe. This is a common (if dubious) idiom. 6035 6036 elsif S = Scope (Prot) 6037 and then Ekind_In (S, E_Package, E_Generic_Package) 6038 and then Nkind (Parent (E)) = N_Object_Declaration 6039 and then Nkind (Parent (Parent (E))) = N_Package_Body 6040 then 6041 null; 6042 6043 else 6044 Error_Msg_N ("potentially unsynchronized barrier??", N); 6045 Error_Msg_N ("\& should be private component of type??", N); 6046 end if; 6047 end if; 6048 end if; 6049 6050 return OK; 6051 end Is_Global_Entity; 6052 6053 procedure Check_Unprotected_Barrier is 6054 new Traverse_Proc (Is_Global_Entity); 6055 6056 ---------------------------- 6057 -- Is_Simple_Barrier_Name -- 6058 ---------------------------- 6059 6060 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is 6061 Renamed : Node_Id; 6062 6063 begin 6064 -- Check if the name is a component of the protected object. If 6065 -- the expander is active, the component has been transformed into a 6066 -- renaming of _object.all.component. Original_Node is needed in case 6067 -- validity checking is enabled, in which case the simple object 6068 -- reference will have been rewritten. 6069 6070 if Expander_Active then 6071 6072 -- The expanded name may have been constant folded in which case 6073 -- the original node is not necessarily an entity name (e.g. an 6074 -- indexed component). 6075 6076 if not Is_Entity_Name (Original_Node (N)) then 6077 return False; 6078 end if; 6079 6080 Renamed := Renamed_Object (Entity (Original_Node (N))); 6081 6082 return 6083 Present (Renamed) 6084 and then Nkind (Renamed) = N_Selected_Component 6085 and then Chars (Prefix (Prefix (Renamed))) = Name_uObject; 6086 else 6087 return Is_Protected_Component (Entity (N)); 6088 end if; 6089 end Is_Simple_Barrier_Name; 6090 6091 --------------------- 6092 -- Is_Pure_Barrier -- 6093 --------------------- 6094 6095 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is 6096 begin 6097 case Nkind (N) is 6098 when N_Expanded_Name 6099 | N_Identifier 6100 => 6101 if No (Entity (N)) then 6102 return Abandon; 6103 6104 elsif Is_Universal_Numeric_Type (Entity (N)) then 6105 return OK; 6106 end if; 6107 6108 case Ekind (Entity (N)) is 6109 when E_Constant 6110 | E_Discriminant 6111 | E_Enumeration_Literal 6112 | E_Named_Integer 6113 | E_Named_Real 6114 => 6115 return OK; 6116 6117 when E_Component => 6118 return OK; 6119 6120 when E_Variable => 6121 if Is_Simple_Barrier_Name (N) then 6122 return OK; 6123 end if; 6124 6125 when E_Function => 6126 6127 -- The count attribute has been transformed into run-time 6128 -- calls. 6129 6130 if Is_RTE (Entity (N), RE_Protected_Count) 6131 or else Is_RTE (Entity (N), RE_Protected_Count_Entry) 6132 then 6133 return OK; 6134 end if; 6135 6136 when others => 6137 null; 6138 end case; 6139 6140 when N_Function_Call => 6141 6142 -- Function call checks are carried out as part of the analysis 6143 -- of the function call name. 6144 6145 return OK; 6146 6147 when N_Character_Literal 6148 | N_Integer_Literal 6149 | N_Real_Literal 6150 => 6151 return OK; 6152 6153 when N_Op_Boolean 6154 | N_Op_Not 6155 => 6156 if Ekind (Entity (N)) = E_Operator then 6157 return OK; 6158 end if; 6159 6160 when N_Short_Circuit => 6161 return OK; 6162 6163 when N_Indexed_Component 6164 | N_Selected_Component 6165 => 6166 if not Is_Access_Type (Etype (Prefix (N))) then 6167 return OK; 6168 end if; 6169 6170 when N_Type_Conversion => 6171 6172 -- Conversions to Universal_Integer will not raise constraint 6173 -- errors. 6174 6175 if Cannot_Raise_Constraint_Error (N) 6176 or else Etype (N) = Universal_Integer 6177 then 6178 return OK; 6179 end if; 6180 6181 when N_Unchecked_Type_Conversion => 6182 return OK; 6183 6184 when others => 6185 null; 6186 end case; 6187 6188 return Abandon; 6189 end Is_Pure_Barrier; 6190 6191 function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier); 6192 6193 -- Local variables 6194 6195 Cond_Id : Entity_Id; 6196 Entry_Body : Node_Id; 6197 Func_Body : Node_Id := Empty; 6198 6199 -- Start of processing for Expand_Entry_Barrier 6200 6201 begin 6202 if No_Run_Time_Mode then 6203 Error_Msg_CRT ("entry barrier", N); 6204 return; 6205 end if; 6206 6207 -- The body of the entry barrier must be analyzed in the context of the 6208 -- protected object, but its scope is external to it, just as any other 6209 -- unprotected version of a protected operation. The specification has 6210 -- been produced when the protected type declaration was elaborated. We 6211 -- build the body, insert it in the enclosing scope, but analyze it in 6212 -- the current context. A more uniform approach would be to treat the 6213 -- barrier just as a protected function, and discard the protected 6214 -- version of it because it is never called. 6215 6216 if Expander_Active then 6217 Func_Body := Build_Barrier_Function (N, Ent, Prot); 6218 Func_Id := Barrier_Function (Ent); 6219 Set_Corresponding_Spec (Func_Body, Func_Id); 6220 6221 Entry_Body := Parent (Corresponding_Body (Spec_Decl)); 6222 6223 if Nkind (Parent (Entry_Body)) = N_Subunit then 6224 Entry_Body := Corresponding_Stub (Parent (Entry_Body)); 6225 end if; 6226 6227 Insert_Before_And_Analyze (Entry_Body, Func_Body); 6228 6229 Set_Discriminals (Spec_Decl); 6230 Set_Scope (Func_Id, Scope (Prot)); 6231 6232 else 6233 Analyze_And_Resolve (Cond, Any_Boolean); 6234 end if; 6235 6236 -- Check Pure_Barriers restriction 6237 6238 if Check_Pure_Barriers (Cond) = Abandon then 6239 Check_Restriction (Pure_Barriers, Cond); 6240 end if; 6241 6242 -- The Ravenscar profile restricts barriers to simple variables declared 6243 -- within the protected object. We also allow Boolean constants, since 6244 -- these appear in several published examples and are also allowed by 6245 -- other compilers. 6246 6247 -- Note that after analysis variables in this context will be replaced 6248 -- by the corresponding prival, that is to say a renaming of a selected 6249 -- component of the form _Object.Var. If expansion is disabled, as 6250 -- within a generic, we check that the entity appears in the current 6251 -- scope. 6252 6253 if Is_Entity_Name (Cond) then 6254 Cond_Id := Entity (Cond); 6255 6256 -- Perform a small optimization of simple barrier functions. If the 6257 -- scope of the condition's entity is not the barrier function, then 6258 -- the condition does not depend on any of the generated renamings. 6259 -- If this is the case, eliminate the renamings as they are useless. 6260 -- This optimization is not performed when the condition was folded 6261 -- and validity checks are in effect because the original condition 6262 -- may have produced at least one check that depends on the generated 6263 -- renamings. 6264 6265 if Expander_Active 6266 and then Scope (Cond_Id) /= Func_Id 6267 and then not Validity_Check_Operands 6268 then 6269 Set_Declarations (Func_Body, Empty_List); 6270 end if; 6271 6272 if Cond_Id = Standard_False or else Cond_Id = Standard_True then 6273 return; 6274 6275 elsif Is_Simple_Barrier_Name (Cond) then 6276 return; 6277 end if; 6278 end if; 6279 6280 -- It is not a boolean variable or literal, so check the restriction. 6281 -- Note that it is safe to be calling Check_Restriction from here, even 6282 -- though this is part of the expander, since Expand_Entry_Barrier is 6283 -- called from Sem_Ch9 even in -gnatc mode. 6284 6285 Check_Restriction (Simple_Barriers, Cond); 6286 6287 -- Emit warning if barrier contains global entities and is thus 6288 -- potentially unsynchronized. 6289 6290 Check_Unprotected_Barrier (Cond); 6291 end Expand_Entry_Barrier; 6292 6293 ------------------------------ 6294 -- Expand_N_Abort_Statement -- 6295 ------------------------------ 6296 6297 -- Expand abort T1, T2, .. Tn; into: 6298 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...)) 6299 6300 procedure Expand_N_Abort_Statement (N : Node_Id) is 6301 Loc : constant Source_Ptr := Sloc (N); 6302 Tlist : constant List_Id := Names (N); 6303 Count : Nat; 6304 Aggr : Node_Id; 6305 Tasknm : Node_Id; 6306 6307 begin 6308 Aggr := Make_Aggregate (Loc, Component_Associations => New_List); 6309 Count := 0; 6310 6311 Tasknm := First (Tlist); 6312 6313 while Present (Tasknm) loop 6314 Count := Count + 1; 6315 6316 -- A task interface class-wide type object is being aborted. Retrieve 6317 -- its _task_id by calling a dispatching routine. 6318 6319 if Ada_Version >= Ada_2005 6320 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type 6321 and then Is_Interface (Etype (Tasknm)) 6322 and then Is_Task_Interface (Etype (Tasknm)) 6323 then 6324 Append_To (Component_Associations (Aggr), 6325 Make_Component_Association (Loc, 6326 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6327 Expression => 6328 6329 -- Task_Id (Tasknm._disp_get_task_id) 6330 6331 Make_Unchecked_Type_Conversion (Loc, 6332 Subtype_Mark => 6333 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 6334 Expression => 6335 Make_Selected_Component (Loc, 6336 Prefix => New_Copy_Tree (Tasknm), 6337 Selector_Name => 6338 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))); 6339 6340 else 6341 Append_To (Component_Associations (Aggr), 6342 Make_Component_Association (Loc, 6343 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6344 Expression => Concurrent_Ref (Tasknm))); 6345 end if; 6346 6347 Next (Tasknm); 6348 end loop; 6349 6350 Rewrite (N, 6351 Make_Procedure_Call_Statement (Loc, 6352 Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc), 6353 Parameter_Associations => New_List ( 6354 Make_Qualified_Expression (Loc, 6355 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_List), Loc), 6356 Expression => Aggr)))); 6357 6358 Analyze (N); 6359 end Expand_N_Abort_Statement; 6360 6361 ------------------------------- 6362 -- Expand_N_Accept_Statement -- 6363 ------------------------------- 6364 6365 -- This procedure handles expansion of accept statements that stand alone, 6366 -- i.e. they are not part of an accept alternative. The expansion of 6367 -- accept statement in accept alternatives is handled by the routines 6368 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The 6369 -- following description applies only to stand alone accept statements. 6370 6371 -- If there is no handled statement sequence, or only null statements, then 6372 -- this is called a trivial accept, and the expansion is: 6373 6374 -- Accept_Trivial (entry-index) 6375 6376 -- If there is a handled statement sequence, then the expansion is: 6377 6378 -- Ann : Address; 6379 -- {Lnn : Label} 6380 6381 -- begin 6382 -- begin 6383 -- Accept_Call (entry-index, Ann); 6384 -- Renaming_Declarations for formals 6385 -- <statement sequence from N_Accept_Statement node> 6386 -- Complete_Rendezvous; 6387 -- <<Lnn>> 6388 -- 6389 -- exception 6390 -- when ... => 6391 -- <exception handler from N_Accept_Statement node> 6392 -- Complete_Rendezvous; 6393 -- when ... => 6394 -- <exception handler from N_Accept_Statement node> 6395 -- Complete_Rendezvous; 6396 -- ... 6397 -- end; 6398 6399 -- exception 6400 -- when all others => 6401 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 6402 -- end; 6403 6404 -- The first three declarations were already inserted ahead of the accept 6405 -- statement by the Expand_Accept_Declarations procedure, which was called 6406 -- directly from the semantics during analysis of the accept statement, 6407 -- before analyzing its contained statements. 6408 6409 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come 6410 -- from possible expansion activity (the original source of course does 6411 -- not have any declarations associated with the accept statement, since 6412 -- an accept statement has no declarative part). In particular, if the 6413 -- expander is active, the first such declaration is the declaration of 6414 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement). 6415 6416 -- The two blocks are merged into a single block if the inner block has 6417 -- no exception handlers, but otherwise two blocks are required, since 6418 -- exceptions might be raised in the exception handlers of the inner 6419 -- block, and Exceptional_Complete_Rendezvous must be called. 6420 6421 procedure Expand_N_Accept_Statement (N : Node_Id) is 6422 Loc : constant Source_Ptr := Sloc (N); 6423 Stats : constant Node_Id := Handled_Statement_Sequence (N); 6424 Ename : constant Node_Id := Entry_Direct_Name (N); 6425 Eindx : constant Node_Id := Entry_Index (N); 6426 Eent : constant Entity_Id := Entity (Ename); 6427 Acstack : constant Elist_Id := Accept_Address (Eent); 6428 Ann : constant Entity_Id := Node (Last_Elmt (Acstack)); 6429 Ttyp : constant Entity_Id := Etype (Scope (Eent)); 6430 Blkent : Entity_Id; 6431 Call : Node_Id; 6432 Block : Node_Id; 6433 6434 begin 6435 -- If the accept statement is not part of a list, then its parent must 6436 -- be an accept alternative, and, as described above, we do not do any 6437 -- expansion for such accept statements at this level. 6438 6439 if not Is_List_Member (N) then 6440 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative); 6441 return; 6442 6443 -- Trivial accept case (no statement sequence, or null statements). 6444 -- If the accept statement has declarations, then just insert them 6445 -- before the procedure call. 6446 6447 elsif Trivial_Accept_OK 6448 and then (No (Stats) or else Null_Statements (Statements (Stats))) 6449 then 6450 -- Remove declarations for renamings, because the parameter block 6451 -- will not be assigned. 6452 6453 declare 6454 D : Node_Id; 6455 Next_D : Node_Id; 6456 6457 begin 6458 D := First (Declarations (N)); 6459 while Present (D) loop 6460 Next_D := Next (D); 6461 if Nkind (D) = N_Object_Renaming_Declaration then 6462 Remove (D); 6463 end if; 6464 6465 D := Next_D; 6466 end loop; 6467 end; 6468 6469 if Present (Declarations (N)) then 6470 Insert_Actions (N, Declarations (N)); 6471 end if; 6472 6473 Rewrite (N, 6474 Make_Procedure_Call_Statement (Loc, 6475 Name => New_Occurrence_Of (RTE (RE_Accept_Trivial), Loc), 6476 Parameter_Associations => New_List ( 6477 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp)))); 6478 6479 Analyze (N); 6480 6481 -- Discard Entry_Address that was created for it, so it will not be 6482 -- emitted if this accept statement is in the statement part of a 6483 -- delay alternative. 6484 6485 if Present (Stats) then 6486 Remove_Last_Elmt (Acstack); 6487 end if; 6488 6489 -- Case of statement sequence present 6490 6491 else 6492 -- Construct the block, using the declarations from the accept 6493 -- statement if any to initialize the declarations of the block. 6494 6495 Blkent := Make_Temporary (Loc, 'A'); 6496 Set_Ekind (Blkent, E_Block); 6497 Set_Etype (Blkent, Standard_Void_Type); 6498 Set_Scope (Blkent, Current_Scope); 6499 6500 Block := 6501 Make_Block_Statement (Loc, 6502 Identifier => New_Occurrence_Of (Blkent, Loc), 6503 Declarations => Declarations (N), 6504 Handled_Statement_Sequence => Build_Accept_Body (N)); 6505 6506 -- For the analysis of the generated declarations, the parent node 6507 -- must be properly set. 6508 6509 Set_Parent (Block, Parent (N)); 6510 6511 -- Prepend call to Accept_Call to main statement sequence If the 6512 -- accept has exception handlers, the statement sequence is wrapped 6513 -- in a block. Insert call and renaming declarations in the 6514 -- declarations of the block, so they are elaborated before the 6515 -- handlers. 6516 6517 Call := 6518 Make_Procedure_Call_Statement (Loc, 6519 Name => New_Occurrence_Of (RTE (RE_Accept_Call), Loc), 6520 Parameter_Associations => New_List ( 6521 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp), 6522 New_Occurrence_Of (Ann, Loc))); 6523 6524 if Parent (Stats) = N then 6525 Prepend (Call, Statements (Stats)); 6526 else 6527 Set_Declarations (Parent (Stats), New_List (Call)); 6528 end if; 6529 6530 Analyze (Call); 6531 6532 Push_Scope (Blkent); 6533 6534 declare 6535 D : Node_Id; 6536 Next_D : Node_Id; 6537 Typ : Entity_Id; 6538 6539 begin 6540 D := First (Declarations (N)); 6541 while Present (D) loop 6542 Next_D := Next (D); 6543 6544 if Nkind (D) = N_Object_Renaming_Declaration then 6545 6546 -- The renaming declarations for the formals were created 6547 -- during analysis of the accept statement, and attached to 6548 -- the list of declarations. Place them now in the context 6549 -- of the accept block or subprogram. 6550 6551 Remove (D); 6552 Typ := Entity (Subtype_Mark (D)); 6553 Insert_After (Call, D); 6554 Analyze (D); 6555 6556 -- If the formal is class_wide, it does not have an actual 6557 -- subtype. The analysis of the renaming declaration creates 6558 -- one, but we need to retain the class-wide nature of the 6559 -- entity. 6560 6561 if Is_Class_Wide_Type (Typ) then 6562 Set_Etype (Defining_Identifier (D), Typ); 6563 end if; 6564 6565 end if; 6566 6567 D := Next_D; 6568 end loop; 6569 end; 6570 6571 End_Scope; 6572 6573 -- Replace the accept statement by the new block 6574 6575 Rewrite (N, Block); 6576 Analyze (N); 6577 6578 -- Last step is to unstack the Accept_Address value 6579 6580 Remove_Last_Elmt (Acstack); 6581 end if; 6582 end Expand_N_Accept_Statement; 6583 6584 ---------------------------------- 6585 -- Expand_N_Asynchronous_Select -- 6586 ---------------------------------- 6587 6588 -- This procedure assumes that the trigger statement is an entry call or 6589 -- a dispatching procedure call. A delay alternative should already have 6590 -- been expanded into an entry call to the appropriate delay object Wait 6591 -- entry. 6592 6593 -- If the trigger is a task entry call, the select is implemented with 6594 -- a Task_Entry_Call: 6595 6596 -- declare 6597 -- B : Boolean; 6598 -- C : Boolean; 6599 -- P : parms := (parm, parm, parm); 6600 6601 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6602 6603 -- procedure _clean is 6604 -- begin 6605 -- ... 6606 -- Cancel_Task_Entry_Call (C); 6607 -- ... 6608 -- end _clean; 6609 6610 -- begin 6611 -- Abort_Defer; 6612 -- Task_Entry_Call 6613 -- (<acceptor-task>, -- Acceptor 6614 -- <entry-index>, -- E 6615 -- P'Address, -- Uninterpreted_Data 6616 -- Asynchronous_Call, -- Mode 6617 -- B); -- Rendezvous_Successful 6618 6619 -- begin 6620 -- begin 6621 -- Abort_Undefer; 6622 -- <abortable-part> 6623 -- at end 6624 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6625 -- end; 6626 -- exception 6627 -- when Abort_Signal => Abort_Undefer; 6628 -- end; 6629 6630 -- parm := P.param; 6631 -- parm := P.param; 6632 -- ... 6633 -- if not C then 6634 -- <triggered-statements> 6635 -- end if; 6636 -- end; 6637 6638 -- Note that Build_Simple_Entry_Call is used to expand the entry of the 6639 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure) 6640 -- as follows: 6641 6642 -- declare 6643 -- P : parms := (parm, parm, parm); 6644 -- begin 6645 -- Call_Simple (acceptor-task, entry-index, P'Address); 6646 -- parm := P.param; 6647 -- parm := P.param; 6648 -- ... 6649 -- end; 6650 6651 -- so the task at hand is to convert the latter expansion into the former 6652 6653 -- If the trigger is a protected entry call, the select is implemented 6654 -- with Protected_Entry_Call: 6655 6656 -- declare 6657 -- P : E1_Params := (param, param, param); 6658 -- Bnn : Communications_Block; 6659 6660 -- begin 6661 -- declare 6662 6663 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6664 6665 -- procedure _clean is 6666 -- begin 6667 -- ... 6668 -- if Enqueued (Bnn) then 6669 -- Cancel_Protected_Entry_Call (Bnn); 6670 -- end if; 6671 -- ... 6672 -- end _clean; 6673 6674 -- begin 6675 -- begin 6676 -- Protected_Entry_Call 6677 -- (po._object'Access, -- Object 6678 -- <entry index>, -- E 6679 -- P'Address, -- Uninterpreted_Data 6680 -- Asynchronous_Call, -- Mode 6681 -- Bnn); -- Block 6682 6683 -- if Enqueued (Bnn) then 6684 -- <abortable-part> 6685 -- end if; 6686 -- at end 6687 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6688 -- end; 6689 -- exception 6690 -- when Abort_Signal => Abort_Undefer; 6691 -- end; 6692 6693 -- if not Cancelled (Bnn) then 6694 -- <triggered-statements> 6695 -- end if; 6696 -- end; 6697 6698 -- Build_Simple_Entry_Call is used to expand the all to a simple protected 6699 -- entry call: 6700 6701 -- declare 6702 -- P : E1_Params := (param, param, param); 6703 -- Bnn : Communications_Block; 6704 6705 -- begin 6706 -- Protected_Entry_Call 6707 -- (po._object'Access, -- Object 6708 -- <entry index>, -- E 6709 -- P'Address, -- Uninterpreted_Data 6710 -- Simple_Call, -- Mode 6711 -- Bnn); -- Block 6712 -- parm := P.param; 6713 -- parm := P.param; 6714 -- ... 6715 -- end; 6716 6717 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is 6718 -- expanded into: 6719 6720 -- declare 6721 -- B : Boolean := False; 6722 -- Bnn : Communication_Block; 6723 -- C : Ada.Tags.Prim_Op_Kind; 6724 -- D : System.Storage_Elements.Dummy_Communication_Block; 6725 -- K : Ada.Tags.Tagged_Kind := 6726 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 6727 -- P : Parameters := (Param1 .. ParamN); 6728 -- S : Integer; 6729 -- U : Boolean; 6730 6731 -- begin 6732 -- if K = Ada.Tags.TK_Limited_Tagged 6733 -- or else K = Ada.Tags.TK_Tagged 6734 -- then 6735 -- <dispatching-call>; 6736 -- <triggering-statements>; 6737 6738 -- else 6739 -- S := 6740 -- Ada.Tags.Get_Offset_Index 6741 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 6742 6743 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 6744 6745 -- if C = POK_Protected_Entry then 6746 -- declare 6747 -- procedure _clean is 6748 -- begin 6749 -- if Enqueued (Bnn) then 6750 -- Cancel_Protected_Entry_Call (Bnn); 6751 -- end if; 6752 -- end _clean; 6753 6754 -- begin 6755 -- begin 6756 -- _Disp_Asynchronous_Select 6757 -- (<object>, S, P'Address, D, B); 6758 -- Bnn := Communication_Block (D); 6759 6760 -- Param1 := P.Param1; 6761 -- ... 6762 -- ParamN := P.ParamN; 6763 6764 -- if Enqueued (Bnn) then 6765 -- <abortable-statements> 6766 -- end if; 6767 -- at end 6768 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6769 -- end; 6770 -- exception 6771 -- when Abort_Signal => Abort_Undefer; 6772 -- end; 6773 6774 -- if not Cancelled (Bnn) then 6775 -- <triggering-statements> 6776 -- end if; 6777 6778 -- elsif C = POK_Task_Entry then 6779 -- declare 6780 -- procedure _clean is 6781 -- begin 6782 -- Cancel_Task_Entry_Call (U); 6783 -- end _clean; 6784 6785 -- begin 6786 -- Abort_Defer; 6787 6788 -- _Disp_Asynchronous_Select 6789 -- (<object>, S, P'Address, D, B); 6790 -- Bnn := Communication_Bloc (D); 6791 6792 -- Param1 := P.Param1; 6793 -- ... 6794 -- ParamN := P.ParamN; 6795 6796 -- begin 6797 -- begin 6798 -- Abort_Undefer; 6799 -- <abortable-statements> 6800 -- at end 6801 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6802 -- end; 6803 -- exception 6804 -- when Abort_Signal => Abort_Undefer; 6805 -- end; 6806 6807 -- if not U then 6808 -- <triggering-statements> 6809 -- end if; 6810 -- end; 6811 6812 -- else 6813 -- <dispatching-call>; 6814 -- <triggering-statements> 6815 -- end if; 6816 -- end if; 6817 -- end; 6818 6819 -- The job is to convert this to the asynchronous form 6820 6821 -- If the trigger is a delay statement, it will have been expanded into 6822 -- a call to one of the GNARL delay procedures. This routine will convert 6823 -- this into a protected entry call on a delay object and then continue 6824 -- processing as for a protected entry call trigger. This requires 6825 -- declaring a Delay_Block object and adding a pointer to this object to 6826 -- the parameter list of the delay procedure to form the parameter list of 6827 -- the entry call. This object is used by the runtime to queue the delay 6828 -- request. 6829 6830 -- For a description of the use of P and the assignments after the call, 6831 -- see Expand_N_Entry_Call_Statement. 6832 6833 procedure Expand_N_Asynchronous_Select (N : Node_Id) is 6834 Loc : constant Source_Ptr := Sloc (N); 6835 Abrt : constant Node_Id := Abortable_Part (N); 6836 Trig : constant Node_Id := Triggering_Alternative (N); 6837 6838 Abort_Block_Ent : Entity_Id; 6839 Abortable_Block : Node_Id; 6840 Actuals : List_Id; 6841 Astats : List_Id; 6842 Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A'); 6843 Blk_Typ : Entity_Id; 6844 Call : Node_Id; 6845 Call_Ent : Entity_Id; 6846 Cancel_Param : Entity_Id; 6847 Cleanup_Block : Node_Id; 6848 Cleanup_Block_Ent : Entity_Id; 6849 Cleanup_Stmts : List_Id; 6850 Conc_Typ_Stmts : List_Id; 6851 Concval : Node_Id; 6852 Dblock_Ent : Entity_Id; 6853 Decl : Node_Id; 6854 Decls : List_Id; 6855 Ecall : Node_Id; 6856 Ename : Node_Id; 6857 Enqueue_Call : Node_Id; 6858 Formals : List_Id; 6859 Hdle : List_Id; 6860 Handler_Stmt : Node_Id; 6861 Index : Node_Id; 6862 Lim_Typ_Stmts : List_Id; 6863 N_Orig : Node_Id; 6864 Obj : Entity_Id; 6865 Param : Node_Id; 6866 Params : List_Id; 6867 Pdef : Entity_Id; 6868 ProtE_Stmts : List_Id; 6869 ProtP_Stmts : List_Id; 6870 Stmt : Node_Id; 6871 Stmts : List_Id; 6872 TaskE_Stmts : List_Id; 6873 Tstats : List_Id; 6874 6875 B : Entity_Id; -- Call status flag 6876 Bnn : Entity_Id; -- Communication block 6877 C : Entity_Id; -- Call kind 6878 K : Entity_Id; -- Tagged kind 6879 P : Entity_Id; -- Parameter block 6880 S : Entity_Id; -- Primitive operation slot 6881 T : Entity_Id; -- Additional status flag 6882 6883 procedure Rewrite_Abortable_Part; 6884 -- If the trigger is a dispatching call, the expansion inserts multiple 6885 -- copies of the abortable part. This is both inefficient, and may lead 6886 -- to duplicate definitions that the back-end will reject, when the 6887 -- abortable part includes loops. This procedure rewrites the abortable 6888 -- part into a call to a generated procedure. 6889 6890 ---------------------------- 6891 -- Rewrite_Abortable_Part -- 6892 ---------------------------- 6893 6894 procedure Rewrite_Abortable_Part is 6895 Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 6896 Decl : Node_Id; 6897 6898 begin 6899 Decl := 6900 Make_Subprogram_Body (Loc, 6901 Specification => 6902 Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc), 6903 Declarations => New_List, 6904 Handled_Statement_Sequence => 6905 Make_Handled_Sequence_Of_Statements (Loc, Astats)); 6906 Insert_Before (N, Decl); 6907 Analyze (Decl); 6908 6909 -- Rewrite abortable part into a call to this procedure 6910 6911 Astats := 6912 New_List ( 6913 Make_Procedure_Call_Statement (Loc, 6914 Name => New_Occurrence_Of (Proc, Loc))); 6915 end Rewrite_Abortable_Part; 6916 6917 -- Start of processing for Expand_N_Asynchronous_Select 6918 6919 begin 6920 -- Asynchronous select is not supported on restricted runtimes. Don't 6921 -- try to expand. 6922 6923 if Restricted_Profile then 6924 return; 6925 end if; 6926 6927 Process_Statements_For_Controlled_Objects (Trig); 6928 Process_Statements_For_Controlled_Objects (Abrt); 6929 6930 Ecall := Triggering_Statement (Trig); 6931 6932 Ensure_Statement_Present (Sloc (Ecall), Trig); 6933 6934 -- Retrieve Astats and Tstats now because the finalization machinery may 6935 -- wrap them in blocks. 6936 6937 Astats := Statements (Abrt); 6938 Tstats := Statements (Trig); 6939 6940 -- The arguments in the call may require dynamic allocation, and the 6941 -- call statement may have been transformed into a block. The block 6942 -- may contain additional declarations for internal entities, and the 6943 -- original call is found by sequential search. 6944 6945 if Nkind (Ecall) = N_Block_Statement then 6946 Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); 6947 while not Nkind_In (Ecall, N_Procedure_Call_Statement, 6948 N_Entry_Call_Statement) 6949 loop 6950 Next (Ecall); 6951 end loop; 6952 end if; 6953 6954 -- This is either a dispatching call or a delay statement used as a 6955 -- trigger which was expanded into a procedure call. 6956 6957 if Nkind (Ecall) = N_Procedure_Call_Statement then 6958 if Ada_Version >= Ada_2005 6959 and then 6960 (No (Original_Node (Ecall)) 6961 or else not Nkind_In (Original_Node (Ecall), 6962 N_Delay_Relative_Statement, 6963 N_Delay_Until_Statement)) 6964 then 6965 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals); 6966 6967 Rewrite_Abortable_Part; 6968 Decls := New_List; 6969 Stmts := New_List; 6970 6971 -- Call status flag processing, generate: 6972 -- B : Boolean := False; 6973 6974 B := Build_B (Loc, Decls); 6975 6976 -- Communication block processing, generate: 6977 -- Bnn : Communication_Block; 6978 6979 Bnn := Make_Temporary (Loc, 'B'); 6980 Append_To (Decls, 6981 Make_Object_Declaration (Loc, 6982 Defining_Identifier => Bnn, 6983 Object_Definition => 6984 New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); 6985 6986 -- Call kind processing, generate: 6987 -- C : Ada.Tags.Prim_Op_Kind; 6988 6989 C := Build_C (Loc, Decls); 6990 6991 -- Tagged kind processing, generate: 6992 -- K : Ada.Tags.Tagged_Kind := 6993 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 6994 6995 -- Dummy communication block, generate: 6996 -- D : Dummy_Communication_Block; 6997 6998 Append_To (Decls, 6999 Make_Object_Declaration (Loc, 7000 Defining_Identifier => 7001 Make_Defining_Identifier (Loc, Name_uD), 7002 Object_Definition => 7003 New_Occurrence_Of 7004 (RTE (RE_Dummy_Communication_Block), Loc))); 7005 7006 K := Build_K (Loc, Decls, Obj); 7007 7008 -- Parameter block processing 7009 7010 Blk_Typ := Build_Parameter_Block 7011 (Loc, Actuals, Formals, Decls); 7012 P := Parameter_Block_Pack 7013 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 7014 7015 -- Dispatch table slot processing, generate: 7016 -- S : Integer; 7017 7018 S := Build_S (Loc, Decls); 7019 7020 -- Additional status flag processing, generate: 7021 -- Tnn : Boolean; 7022 7023 T := Make_Temporary (Loc, 'T'); 7024 Append_To (Decls, 7025 Make_Object_Declaration (Loc, 7026 Defining_Identifier => T, 7027 Object_Definition => 7028 New_Occurrence_Of (Standard_Boolean, Loc))); 7029 7030 ------------------------------ 7031 -- Protected entry handling -- 7032 ------------------------------ 7033 7034 -- Generate: 7035 -- Param1 := P.Param1; 7036 -- ... 7037 -- ParamN := P.ParamN; 7038 7039 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7040 7041 -- Generate: 7042 -- Bnn := Communication_Block (D); 7043 7044 Prepend_To (Cleanup_Stmts, 7045 Make_Assignment_Statement (Loc, 7046 Name => New_Occurrence_Of (Bnn, Loc), 7047 Expression => 7048 Make_Unchecked_Type_Conversion (Loc, 7049 Subtype_Mark => 7050 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7051 Expression => Make_Identifier (Loc, Name_uD)))); 7052 7053 -- Generate: 7054 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7055 7056 Prepend_To (Cleanup_Stmts, 7057 Make_Procedure_Call_Statement (Loc, 7058 Name => 7059 New_Occurrence_Of 7060 (Find_Prim_Op 7061 (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select), 7062 Loc), 7063 Parameter_Associations => 7064 New_List ( 7065 New_Copy_Tree (Obj), -- <object> 7066 New_Occurrence_Of (S, Loc), -- S 7067 Make_Attribute_Reference (Loc, -- P'Address 7068 Prefix => New_Occurrence_Of (P, Loc), 7069 Attribute_Name => Name_Address), 7070 Make_Identifier (Loc, Name_uD), -- D 7071 New_Occurrence_Of (B, Loc)))); -- B 7072 7073 -- Generate: 7074 -- if Enqueued (Bnn) then 7075 -- <abortable-statements> 7076 -- end if; 7077 7078 Append_To (Cleanup_Stmts, 7079 Make_Implicit_If_Statement (N, 7080 Condition => 7081 Make_Function_Call (Loc, 7082 Name => 7083 New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7084 Parameter_Associations => 7085 New_List (New_Occurrence_Of (Bnn, Loc))), 7086 7087 Then_Statements => 7088 New_Copy_List_Tree (Astats))); 7089 7090 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7091 -- will then generate a _clean for the communication block Bnn. 7092 7093 -- Generate: 7094 -- declare 7095 -- procedure _clean is 7096 -- begin 7097 -- if Enqueued (Bnn) then 7098 -- Cancel_Protected_Entry_Call (Bnn); 7099 -- end if; 7100 -- end _clean; 7101 -- begin 7102 -- Cleanup_Stmts 7103 -- at end 7104 -- _clean; 7105 -- end; 7106 7107 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7108 Cleanup_Block := 7109 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn); 7110 7111 -- Wrap the cleanup block in an exception handling block 7112 7113 -- Generate: 7114 -- begin 7115 -- Cleanup_Block 7116 -- exception 7117 -- when Abort_Signal => Abort_Undefer; 7118 -- end; 7119 7120 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7121 ProtE_Stmts := 7122 New_List ( 7123 Make_Implicit_Label_Declaration (Loc, 7124 Defining_Identifier => Abort_Block_Ent), 7125 7126 Build_Abort_Block 7127 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7128 7129 -- Generate: 7130 -- if not Cancelled (Bnn) then 7131 -- <triggering-statements> 7132 -- end if; 7133 7134 Append_To (ProtE_Stmts, 7135 Make_Implicit_If_Statement (N, 7136 Condition => 7137 Make_Op_Not (Loc, 7138 Right_Opnd => 7139 Make_Function_Call (Loc, 7140 Name => 7141 New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7142 Parameter_Associations => 7143 New_List (New_Occurrence_Of (Bnn, Loc)))), 7144 7145 Then_Statements => 7146 New_Copy_List_Tree (Tstats))); 7147 7148 ------------------------- 7149 -- Task entry handling -- 7150 ------------------------- 7151 7152 -- Generate: 7153 -- Param1 := P.Param1; 7154 -- ... 7155 -- ParamN := P.ParamN; 7156 7157 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7158 7159 -- Generate: 7160 -- Bnn := Communication_Block (D); 7161 7162 Append_To (TaskE_Stmts, 7163 Make_Assignment_Statement (Loc, 7164 Name => 7165 New_Occurrence_Of (Bnn, Loc), 7166 Expression => 7167 Make_Unchecked_Type_Conversion (Loc, 7168 Subtype_Mark => 7169 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7170 Expression => Make_Identifier (Loc, Name_uD)))); 7171 7172 -- Generate: 7173 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7174 7175 Prepend_To (TaskE_Stmts, 7176 Make_Procedure_Call_Statement (Loc, 7177 Name => 7178 New_Occurrence_Of ( 7179 Find_Prim_Op (Etype (Etype (Obj)), 7180 Name_uDisp_Asynchronous_Select), 7181 Loc), 7182 7183 Parameter_Associations => New_List ( 7184 New_Copy_Tree (Obj), -- <object> 7185 New_Occurrence_Of (S, Loc), -- S 7186 Make_Attribute_Reference (Loc, -- P'Address 7187 Prefix => New_Occurrence_Of (P, Loc), 7188 Attribute_Name => Name_Address), 7189 Make_Identifier (Loc, Name_uD), -- D 7190 New_Occurrence_Of (B, Loc)))); -- B 7191 7192 -- Generate: 7193 -- Abort_Defer; 7194 7195 Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 7196 7197 -- Generate: 7198 -- Abort_Undefer; 7199 -- <abortable-statements> 7200 7201 Cleanup_Stmts := New_Copy_List_Tree (Astats); 7202 7203 Prepend_To 7204 (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7205 7206 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7207 -- will generate a _clean for the additional status flag. 7208 7209 -- Generate: 7210 -- declare 7211 -- procedure _clean is 7212 -- begin 7213 -- Cancel_Task_Entry_Call (U); 7214 -- end _clean; 7215 -- begin 7216 -- Cleanup_Stmts 7217 -- at end 7218 -- _clean; 7219 -- end; 7220 7221 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7222 Cleanup_Block := 7223 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T); 7224 7225 -- Wrap the cleanup block in an exception handling block 7226 7227 -- Generate: 7228 -- begin 7229 -- Cleanup_Block 7230 -- exception 7231 -- when Abort_Signal => Abort_Undefer; 7232 -- end; 7233 7234 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7235 7236 Append_To (TaskE_Stmts, 7237 Make_Implicit_Label_Declaration (Loc, 7238 Defining_Identifier => Abort_Block_Ent)); 7239 7240 Append_To (TaskE_Stmts, 7241 Build_Abort_Block 7242 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7243 7244 -- Generate: 7245 -- if not T then 7246 -- <triggering-statements> 7247 -- end if; 7248 7249 Append_To (TaskE_Stmts, 7250 Make_Implicit_If_Statement (N, 7251 Condition => 7252 Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)), 7253 7254 Then_Statements => 7255 New_Copy_List_Tree (Tstats))); 7256 7257 ---------------------------------- 7258 -- Protected procedure handling -- 7259 ---------------------------------- 7260 7261 -- Generate: 7262 -- <dispatching-call>; 7263 -- <triggering-statements> 7264 7265 ProtP_Stmts := New_Copy_List_Tree (Tstats); 7266 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall)); 7267 7268 -- Generate: 7269 -- S := Ada.Tags.Get_Offset_Index 7270 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 7271 7272 Conc_Typ_Stmts := 7273 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 7274 7275 -- Generate: 7276 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 7277 7278 Append_To (Conc_Typ_Stmts, 7279 Make_Procedure_Call_Statement (Loc, 7280 Name => 7281 New_Occurrence_Of 7282 (Find_Prim_Op (Etype (Etype (Obj)), 7283 Name_uDisp_Get_Prim_Op_Kind), 7284 Loc), 7285 Parameter_Associations => 7286 New_List ( 7287 New_Copy_Tree (Obj), 7288 New_Occurrence_Of (S, Loc), 7289 New_Occurrence_Of (C, Loc)))); 7290 7291 -- Generate: 7292 -- if C = POK_Procedure_Entry then 7293 -- ProtE_Stmts 7294 -- elsif C = POK_Task_Entry then 7295 -- TaskE_Stmts 7296 -- else 7297 -- ProtP_Stmts 7298 -- end if; 7299 7300 Append_To (Conc_Typ_Stmts, 7301 Make_Implicit_If_Statement (N, 7302 Condition => 7303 Make_Op_Eq (Loc, 7304 Left_Opnd => 7305 New_Occurrence_Of (C, Loc), 7306 Right_Opnd => 7307 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 7308 7309 Then_Statements => 7310 ProtE_Stmts, 7311 7312 Elsif_Parts => 7313 New_List ( 7314 Make_Elsif_Part (Loc, 7315 Condition => 7316 Make_Op_Eq (Loc, 7317 Left_Opnd => 7318 New_Occurrence_Of (C, Loc), 7319 Right_Opnd => 7320 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)), 7321 7322 Then_Statements => 7323 TaskE_Stmts)), 7324 7325 Else_Statements => 7326 ProtP_Stmts)); 7327 7328 -- Generate: 7329 -- <dispatching-call>; 7330 -- <triggering-statements> 7331 7332 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats); 7333 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall)); 7334 7335 -- Generate: 7336 -- if K = Ada.Tags.TK_Limited_Tagged 7337 -- or else K = Ada.Tags.TK_Tagged 7338 -- then 7339 -- Lim_Typ_Stmts 7340 -- else 7341 -- Conc_Typ_Stmts 7342 -- end if; 7343 7344 Append_To (Stmts, 7345 Make_Implicit_If_Statement (N, 7346 Condition => Build_Dispatching_Tag_Check (K, N), 7347 Then_Statements => Lim_Typ_Stmts, 7348 Else_Statements => Conc_Typ_Stmts)); 7349 7350 Rewrite (N, 7351 Make_Block_Statement (Loc, 7352 Declarations => 7353 Decls, 7354 Handled_Statement_Sequence => 7355 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7356 7357 Analyze (N); 7358 return; 7359 7360 -- Delay triggering statement processing 7361 7362 else 7363 -- Add a Delay_Block object to the parameter list of the delay 7364 -- procedure to form the parameter list of the Wait entry call. 7365 7366 Dblock_Ent := Make_Temporary (Loc, 'D'); 7367 7368 Pdef := Entity (Name (Ecall)); 7369 7370 if Is_RTE (Pdef, RO_CA_Delay_For) then 7371 Enqueue_Call := 7372 New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc); 7373 7374 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then 7375 Enqueue_Call := 7376 New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc); 7377 7378 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); 7379 Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc); 7380 end if; 7381 7382 Append_To (Parameter_Associations (Ecall), 7383 Make_Attribute_Reference (Loc, 7384 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7385 Attribute_Name => Name_Unchecked_Access)); 7386 7387 -- Create the inner block to protect the abortable part 7388 7389 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7390 7391 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7392 7393 Abortable_Block := 7394 Make_Block_Statement (Loc, 7395 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7396 Handled_Statement_Sequence => 7397 Make_Handled_Sequence_Of_Statements (Loc, 7398 Statements => Astats), 7399 Has_Created_Identifier => True, 7400 Is_Asynchronous_Call_Block => True); 7401 7402 -- Append call to if Enqueue (When, DB'Unchecked_Access) then 7403 7404 Rewrite (Ecall, 7405 Make_Implicit_If_Statement (N, 7406 Condition => 7407 Make_Function_Call (Loc, 7408 Name => Enqueue_Call, 7409 Parameter_Associations => Parameter_Associations (Ecall)), 7410 Then_Statements => 7411 New_List (Make_Block_Statement (Loc, 7412 Handled_Statement_Sequence => 7413 Make_Handled_Sequence_Of_Statements (Loc, 7414 Statements => New_List ( 7415 Make_Implicit_Label_Declaration (Loc, 7416 Defining_Identifier => Blk_Ent, 7417 Label_Construct => Abortable_Block), 7418 Abortable_Block), 7419 Exception_Handlers => Hdle))))); 7420 7421 Stmts := New_List (Ecall); 7422 7423 -- Construct statement sequence for new block 7424 7425 Append_To (Stmts, 7426 Make_Implicit_If_Statement (N, 7427 Condition => 7428 Make_Function_Call (Loc, 7429 Name => New_Occurrence_Of ( 7430 RTE (RE_Timed_Out), Loc), 7431 Parameter_Associations => New_List ( 7432 Make_Attribute_Reference (Loc, 7433 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7434 Attribute_Name => Name_Unchecked_Access))), 7435 Then_Statements => Tstats)); 7436 7437 -- The result is the new block 7438 7439 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent); 7440 7441 Rewrite (N, 7442 Make_Block_Statement (Loc, 7443 Declarations => New_List ( 7444 Make_Object_Declaration (Loc, 7445 Defining_Identifier => Dblock_Ent, 7446 Aliased_Present => True, 7447 Object_Definition => 7448 New_Occurrence_Of (RTE (RE_Delay_Block), Loc))), 7449 7450 Handled_Statement_Sequence => 7451 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7452 7453 Analyze (N); 7454 return; 7455 end if; 7456 7457 else 7458 N_Orig := N; 7459 end if; 7460 7461 Extract_Entry (Ecall, Concval, Ename, Index); 7462 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index); 7463 7464 Stmts := Statements (Handled_Statement_Sequence (Ecall)); 7465 Decls := Declarations (Ecall); 7466 7467 if Is_Protected_Type (Etype (Concval)) then 7468 7469 -- Get the declarations of the block expanded from the entry call 7470 7471 Decl := First (Decls); 7472 while Present (Decl) 7473 and then (Nkind (Decl) /= N_Object_Declaration 7474 or else not Is_RTE (Etype (Object_Definition (Decl)), 7475 RE_Communication_Block)) 7476 loop 7477 Next (Decl); 7478 end loop; 7479 7480 pragma Assert (Present (Decl)); 7481 Cancel_Param := Defining_Identifier (Decl); 7482 7483 -- Change the mode of the Protected_Entry_Call call 7484 7485 -- Protected_Entry_Call ( 7486 -- Object => po._object'Access, 7487 -- E => <entry index>; 7488 -- Uninterpreted_Data => P'Address; 7489 -- Mode => Asynchronous_Call; 7490 -- Block => Bnn); 7491 7492 -- Skip assignments to temporaries created for in-out parameters 7493 7494 -- This makes unwarranted assumptions about the shape of the expanded 7495 -- tree for the call, and should be cleaned up ??? 7496 7497 Stmt := First (Stmts); 7498 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7499 Next (Stmt); 7500 end loop; 7501 7502 Call := Stmt; 7503 7504 Param := First (Parameter_Associations (Call)); 7505 while Present (Param) 7506 and then not Is_RTE (Etype (Param), RE_Call_Modes) 7507 loop 7508 Next (Param); 7509 end loop; 7510 7511 pragma Assert (Present (Param)); 7512 Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7513 Analyze (Param); 7514 7515 -- Append an if statement to execute the abortable part 7516 7517 -- Generate: 7518 -- if Enqueued (Bnn) then 7519 7520 Append_To (Stmts, 7521 Make_Implicit_If_Statement (N, 7522 Condition => 7523 Make_Function_Call (Loc, 7524 Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7525 Parameter_Associations => New_List ( 7526 New_Occurrence_Of (Cancel_Param, Loc))), 7527 Then_Statements => Astats)); 7528 7529 Abortable_Block := 7530 Make_Block_Statement (Loc, 7531 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7532 Handled_Statement_Sequence => 7533 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts), 7534 Has_Created_Identifier => True, 7535 Is_Asynchronous_Call_Block => True); 7536 7537 -- Aborts are not deferred at beginning of exception handlers in 7538 -- ZCX mode. 7539 7540 if ZCX_Exceptions then 7541 Handler_Stmt := Make_Null_Statement (Loc); 7542 7543 else 7544 Handler_Stmt := Build_Runtime_Call (Loc, RE_Abort_Undefer); 7545 end if; 7546 7547 Stmts := New_List ( 7548 Make_Block_Statement (Loc, 7549 Handled_Statement_Sequence => 7550 Make_Handled_Sequence_Of_Statements (Loc, 7551 Statements => New_List ( 7552 Make_Implicit_Label_Declaration (Loc, 7553 Defining_Identifier => Blk_Ent, 7554 Label_Construct => Abortable_Block), 7555 Abortable_Block), 7556 7557 -- exception 7558 7559 Exception_Handlers => New_List ( 7560 Make_Implicit_Exception_Handler (Loc, 7561 7562 -- when Abort_Signal => 7563 -- Abort_Undefer.all; 7564 7565 Exception_Choices => 7566 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)), 7567 Statements => New_List (Handler_Stmt))))), 7568 7569 -- if not Cancelled (Bnn) then 7570 -- triggered statements 7571 -- end if; 7572 7573 Make_Implicit_If_Statement (N, 7574 Condition => Make_Op_Not (Loc, 7575 Right_Opnd => 7576 Make_Function_Call (Loc, 7577 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7578 Parameter_Associations => New_List ( 7579 New_Occurrence_Of (Cancel_Param, Loc)))), 7580 Then_Statements => Tstats)); 7581 7582 -- Asynchronous task entry call 7583 7584 else 7585 if No (Decls) then 7586 Decls := New_List; 7587 end if; 7588 7589 B := Make_Defining_Identifier (Loc, Name_uB); 7590 7591 -- Insert declaration of B in declarations of existing block 7592 7593 Prepend_To (Decls, 7594 Make_Object_Declaration (Loc, 7595 Defining_Identifier => B, 7596 Object_Definition => 7597 New_Occurrence_Of (Standard_Boolean, Loc))); 7598 7599 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC); 7600 7601 -- Insert the declaration of C in the declarations of the existing 7602 -- block. The variable is initialized to something (True or False, 7603 -- does not matter) to prevent CodePeer from complaining about a 7604 -- possible read of an uninitialized variable. 7605 7606 Prepend_To (Decls, 7607 Make_Object_Declaration (Loc, 7608 Defining_Identifier => Cancel_Param, 7609 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 7610 Expression => New_Occurrence_Of (Standard_False, Loc), 7611 Has_Init_Expression => True)); 7612 7613 -- Remove and save the call to Call_Simple 7614 7615 Stmt := First (Stmts); 7616 7617 -- Skip assignments to temporaries created for in-out parameters. 7618 -- This makes unwarranted assumptions about the shape of the expanded 7619 -- tree for the call, and should be cleaned up ??? 7620 7621 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7622 Next (Stmt); 7623 end loop; 7624 7625 Call := Stmt; 7626 7627 -- Create the inner block to protect the abortable part 7628 7629 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7630 7631 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7632 7633 Abortable_Block := 7634 Make_Block_Statement (Loc, 7635 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7636 Handled_Statement_Sequence => 7637 Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats), 7638 Has_Created_Identifier => True, 7639 Is_Asynchronous_Call_Block => True); 7640 7641 Insert_After (Call, 7642 Make_Block_Statement (Loc, 7643 Handled_Statement_Sequence => 7644 Make_Handled_Sequence_Of_Statements (Loc, 7645 Statements => New_List ( 7646 Make_Implicit_Label_Declaration (Loc, 7647 Defining_Identifier => Blk_Ent, 7648 Label_Construct => Abortable_Block), 7649 Abortable_Block), 7650 Exception_Handlers => Hdle))); 7651 7652 -- Create new call statement 7653 7654 Params := Parameter_Associations (Call); 7655 7656 Append_To (Params, 7657 New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7658 Append_To (Params, New_Occurrence_Of (B, Loc)); 7659 7660 Rewrite (Call, 7661 Make_Procedure_Call_Statement (Loc, 7662 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 7663 Parameter_Associations => Params)); 7664 7665 -- Construct statement sequence for new block 7666 7667 Append_To (Stmts, 7668 Make_Implicit_If_Statement (N, 7669 Condition => 7670 Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)), 7671 Then_Statements => Tstats)); 7672 7673 -- Protected the call against abort 7674 7675 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 7676 end if; 7677 7678 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param); 7679 7680 -- The result is the new block 7681 7682 Rewrite (N_Orig, 7683 Make_Block_Statement (Loc, 7684 Declarations => Decls, 7685 Handled_Statement_Sequence => 7686 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7687 7688 Analyze (N_Orig); 7689 end Expand_N_Asynchronous_Select; 7690 7691 ------------------------------------- 7692 -- Expand_N_Conditional_Entry_Call -- 7693 ------------------------------------- 7694 7695 -- The conditional task entry call is converted to a call to 7696 -- Task_Entry_Call: 7697 7698 -- declare 7699 -- B : Boolean; 7700 -- P : parms := (parm, parm, parm); 7701 7702 -- begin 7703 -- Task_Entry_Call 7704 -- (<acceptor-task>, -- Acceptor 7705 -- <entry-index>, -- E 7706 -- P'Address, -- Uninterpreted_Data 7707 -- Conditional_Call, -- Mode 7708 -- B); -- Rendezvous_Successful 7709 -- parm := P.param; 7710 -- parm := P.param; 7711 -- ... 7712 -- if B then 7713 -- normal-statements 7714 -- else 7715 -- else-statements 7716 -- end if; 7717 -- end; 7718 7719 -- For a description of the use of P and the assignments after the call, 7720 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the 7721 -- conditional entry call has already been expanded (by the Expand_N_Entry 7722 -- _Call_Statement procedure) as follows: 7723 7724 -- declare 7725 -- P : parms := (parm, parm, parm); 7726 -- begin 7727 -- ... info for in-out parameters 7728 -- Call_Simple (acceptor-task, entry-index, P'Address); 7729 -- parm := P.param; 7730 -- parm := P.param; 7731 -- ... 7732 -- end; 7733 7734 -- so the task at hand is to convert the latter expansion into the former 7735 7736 -- The conditional protected entry call is converted to a call to 7737 -- Protected_Entry_Call: 7738 7739 -- declare 7740 -- P : parms := (parm, parm, parm); 7741 -- Bnn : Communications_Block; 7742 7743 -- begin 7744 -- Protected_Entry_Call 7745 -- (po._object'Access, -- Object 7746 -- <entry index>, -- E 7747 -- P'Address, -- Uninterpreted_Data 7748 -- Conditional_Call, -- Mode 7749 -- Bnn); -- Block 7750 -- parm := P.param; 7751 -- parm := P.param; 7752 -- ... 7753 -- if Cancelled (Bnn) then 7754 -- else-statements 7755 -- else 7756 -- normal-statements 7757 -- end if; 7758 -- end; 7759 7760 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted 7761 -- into: 7762 7763 -- declare 7764 -- B : Boolean := False; 7765 -- C : Ada.Tags.Prim_Op_Kind; 7766 -- K : Ada.Tags.Tagged_Kind := 7767 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7768 -- P : Parameters := (Param1 .. ParamN); 7769 -- S : Integer; 7770 7771 -- begin 7772 -- if K = Ada.Tags.TK_Limited_Tagged 7773 -- or else K = Ada.Tags.TK_Tagged 7774 -- then 7775 -- <dispatching-call>; 7776 -- <triggering-statements> 7777 7778 -- else 7779 -- S := 7780 -- Ada.Tags.Get_Offset_Index 7781 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 7782 7783 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 7784 7785 -- if C = POK_Protected_Entry 7786 -- or else C = POK_Task_Entry 7787 -- then 7788 -- Param1 := P.Param1; 7789 -- ... 7790 -- ParamN := P.ParamN; 7791 -- end if; 7792 7793 -- if B then 7794 -- if C = POK_Procedure 7795 -- or else C = POK_Protected_Procedure 7796 -- or else C = POK_Task_Procedure 7797 -- then 7798 -- <dispatching-call>; 7799 -- end if; 7800 7801 -- <triggering-statements> 7802 -- else 7803 -- <else-statements> 7804 -- end if; 7805 -- end if; 7806 -- end; 7807 7808 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is 7809 Loc : constant Source_Ptr := Sloc (N); 7810 Alt : constant Node_Id := Entry_Call_Alternative (N); 7811 Blk : Node_Id := Entry_Call_Statement (Alt); 7812 7813 Actuals : List_Id; 7814 Blk_Typ : Entity_Id; 7815 Call : Node_Id; 7816 Call_Ent : Entity_Id; 7817 Conc_Typ_Stmts : List_Id; 7818 Decl : Node_Id; 7819 Decls : List_Id; 7820 Formals : List_Id; 7821 Lim_Typ_Stmts : List_Id; 7822 N_Stats : List_Id; 7823 Obj : Entity_Id; 7824 Param : Node_Id; 7825 Params : List_Id; 7826 Stmt : Node_Id; 7827 Stmts : List_Id; 7828 Transient_Blk : Node_Id; 7829 Unpack : List_Id; 7830 7831 B : Entity_Id; -- Call status flag 7832 C : Entity_Id; -- Call kind 7833 K : Entity_Id; -- Tagged kind 7834 P : Entity_Id; -- Parameter block 7835 S : Entity_Id; -- Primitive operation slot 7836 7837 begin 7838 Process_Statements_For_Controlled_Objects (N); 7839 7840 if Ada_Version >= Ada_2005 7841 and then Nkind (Blk) = N_Procedure_Call_Statement 7842 then 7843 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals); 7844 7845 Decls := New_List; 7846 Stmts := New_List; 7847 7848 -- Call status flag processing, generate: 7849 -- B : Boolean := False; 7850 7851 B := Build_B (Loc, Decls); 7852 7853 -- Call kind processing, generate: 7854 -- C : Ada.Tags.Prim_Op_Kind; 7855 7856 C := Build_C (Loc, Decls); 7857 7858 -- Tagged kind processing, generate: 7859 -- K : Ada.Tags.Tagged_Kind := 7860 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7861 7862 K := Build_K (Loc, Decls, Obj); 7863 7864 -- Parameter block processing 7865 7866 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 7867 P := Parameter_Block_Pack 7868 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 7869 7870 -- Dispatch table slot processing, generate: 7871 -- S : Integer; 7872 7873 S := Build_S (Loc, Decls); 7874 7875 -- Generate: 7876 -- S := Ada.Tags.Get_Offset_Index 7877 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 7878 7879 Conc_Typ_Stmts := 7880 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 7881 7882 -- Generate: 7883 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 7884 7885 Append_To (Conc_Typ_Stmts, 7886 Make_Procedure_Call_Statement (Loc, 7887 Name => 7888 New_Occurrence_Of ( 7889 Find_Prim_Op (Etype (Etype (Obj)), 7890 Name_uDisp_Conditional_Select), 7891 Loc), 7892 Parameter_Associations => 7893 New_List ( 7894 New_Copy_Tree (Obj), -- <object> 7895 New_Occurrence_Of (S, Loc), -- S 7896 Make_Attribute_Reference (Loc, -- P'Address 7897 Prefix => New_Occurrence_Of (P, Loc), 7898 Attribute_Name => Name_Address), 7899 New_Occurrence_Of (C, Loc), -- C 7900 New_Occurrence_Of (B, Loc)))); -- B 7901 7902 -- Generate: 7903 -- if C = POK_Protected_Entry 7904 -- or else C = POK_Task_Entry 7905 -- then 7906 -- Param1 := P.Param1; 7907 -- ... 7908 -- ParamN := P.ParamN; 7909 -- end if; 7910 7911 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7912 7913 -- Generate the if statement only when the packed parameters need 7914 -- explicit assignments to their corresponding actuals. 7915 7916 if Present (Unpack) then 7917 Append_To (Conc_Typ_Stmts, 7918 Make_Implicit_If_Statement (N, 7919 Condition => 7920 Make_Or_Else (Loc, 7921 Left_Opnd => 7922 Make_Op_Eq (Loc, 7923 Left_Opnd => 7924 New_Occurrence_Of (C, Loc), 7925 Right_Opnd => 7926 New_Occurrence_Of (RTE ( 7927 RE_POK_Protected_Entry), Loc)), 7928 7929 Right_Opnd => 7930 Make_Op_Eq (Loc, 7931 Left_Opnd => 7932 New_Occurrence_Of (C, Loc), 7933 Right_Opnd => 7934 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 7935 7936 Then_Statements => Unpack)); 7937 end if; 7938 7939 -- Generate: 7940 -- if B then 7941 -- if C = POK_Procedure 7942 -- or else C = POK_Protected_Procedure 7943 -- or else C = POK_Task_Procedure 7944 -- then 7945 -- <dispatching-call> 7946 -- end if; 7947 -- <normal-statements> 7948 -- else 7949 -- <else-statements> 7950 -- end if; 7951 7952 N_Stats := New_Copy_List_Tree (Statements (Alt)); 7953 7954 Prepend_To (N_Stats, 7955 Make_Implicit_If_Statement (N, 7956 Condition => 7957 Make_Or_Else (Loc, 7958 Left_Opnd => 7959 Make_Op_Eq (Loc, 7960 Left_Opnd => 7961 New_Occurrence_Of (C, Loc), 7962 Right_Opnd => 7963 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 7964 7965 Right_Opnd => 7966 Make_Or_Else (Loc, 7967 Left_Opnd => 7968 Make_Op_Eq (Loc, 7969 Left_Opnd => 7970 New_Occurrence_Of (C, Loc), 7971 Right_Opnd => 7972 New_Occurrence_Of (RTE ( 7973 RE_POK_Protected_Procedure), Loc)), 7974 7975 Right_Opnd => 7976 Make_Op_Eq (Loc, 7977 Left_Opnd => 7978 New_Occurrence_Of (C, Loc), 7979 Right_Opnd => 7980 New_Occurrence_Of (RTE ( 7981 RE_POK_Task_Procedure), Loc)))), 7982 7983 Then_Statements => 7984 New_List (Blk))); 7985 7986 Append_To (Conc_Typ_Stmts, 7987 Make_Implicit_If_Statement (N, 7988 Condition => New_Occurrence_Of (B, Loc), 7989 Then_Statements => N_Stats, 7990 Else_Statements => Else_Statements (N))); 7991 7992 -- Generate: 7993 -- <dispatching-call>; 7994 -- <triggering-statements> 7995 7996 Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt)); 7997 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); 7998 7999 -- Generate: 8000 -- if K = Ada.Tags.TK_Limited_Tagged 8001 -- or else K = Ada.Tags.TK_Tagged 8002 -- then 8003 -- Lim_Typ_Stmts 8004 -- else 8005 -- Conc_Typ_Stmts 8006 -- end if; 8007 8008 Append_To (Stmts, 8009 Make_Implicit_If_Statement (N, 8010 Condition => Build_Dispatching_Tag_Check (K, N), 8011 Then_Statements => Lim_Typ_Stmts, 8012 Else_Statements => Conc_Typ_Stmts)); 8013 8014 Rewrite (N, 8015 Make_Block_Statement (Loc, 8016 Declarations => 8017 Decls, 8018 Handled_Statement_Sequence => 8019 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8020 8021 -- As described above, the entry alternative is transformed into a 8022 -- block that contains the gnulli call, and possibly assignment 8023 -- statements for in-out parameters. The gnulli call may itself be 8024 -- rewritten into a transient block if some unconstrained parameters 8025 -- require it. We need to retrieve the call to complete its parameter 8026 -- list. 8027 8028 else 8029 Transient_Blk := 8030 First_Real_Statement (Handled_Statement_Sequence (Blk)); 8031 8032 if Present (Transient_Blk) 8033 and then Nkind (Transient_Blk) = N_Block_Statement 8034 then 8035 Blk := Transient_Blk; 8036 end if; 8037 8038 Stmts := Statements (Handled_Statement_Sequence (Blk)); 8039 Stmt := First (Stmts); 8040 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 8041 Next (Stmt); 8042 end loop; 8043 8044 Call := Stmt; 8045 Params := Parameter_Associations (Call); 8046 8047 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then 8048 8049 -- Substitute Conditional_Entry_Call for Simple_Call parameter 8050 8051 Param := First (Params); 8052 while Present (Param) 8053 and then not Is_RTE (Etype (Param), RE_Call_Modes) 8054 loop 8055 Next (Param); 8056 end loop; 8057 8058 pragma Assert (Present (Param)); 8059 Rewrite (Param, 8060 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8061 8062 Analyze (Param); 8063 8064 -- Find the Communication_Block parameter for the call to the 8065 -- Cancelled function. 8066 8067 Decl := First (Declarations (Blk)); 8068 while Present (Decl) 8069 and then not Is_RTE (Etype (Object_Definition (Decl)), 8070 RE_Communication_Block) 8071 loop 8072 Next (Decl); 8073 end loop; 8074 8075 -- Add an if statement to execute the else part if the call 8076 -- does not succeed (as indicated by the Cancelled predicate). 8077 8078 Append_To (Stmts, 8079 Make_Implicit_If_Statement (N, 8080 Condition => Make_Function_Call (Loc, 8081 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 8082 Parameter_Associations => New_List ( 8083 New_Occurrence_Of (Defining_Identifier (Decl), Loc))), 8084 Then_Statements => Else_Statements (N), 8085 Else_Statements => Statements (Alt))); 8086 8087 else 8088 B := Make_Defining_Identifier (Loc, Name_uB); 8089 8090 -- Insert declaration of B in declarations of existing block 8091 8092 if No (Declarations (Blk)) then 8093 Set_Declarations (Blk, New_List); 8094 end if; 8095 8096 Prepend_To (Declarations (Blk), 8097 Make_Object_Declaration (Loc, 8098 Defining_Identifier => B, 8099 Object_Definition => 8100 New_Occurrence_Of (Standard_Boolean, Loc))); 8101 8102 -- Create new call statement 8103 8104 Append_To (Params, 8105 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8106 Append_To (Params, New_Occurrence_Of (B, Loc)); 8107 8108 Rewrite (Call, 8109 Make_Procedure_Call_Statement (Loc, 8110 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 8111 Parameter_Associations => Params)); 8112 8113 -- Construct statement sequence for new block 8114 8115 Append_To (Stmts, 8116 Make_Implicit_If_Statement (N, 8117 Condition => New_Occurrence_Of (B, Loc), 8118 Then_Statements => Statements (Alt), 8119 Else_Statements => Else_Statements (N))); 8120 end if; 8121 8122 -- The result is the new block 8123 8124 Rewrite (N, 8125 Make_Block_Statement (Loc, 8126 Declarations => Declarations (Blk), 8127 Handled_Statement_Sequence => 8128 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8129 end if; 8130 8131 Analyze (N); 8132 end Expand_N_Conditional_Entry_Call; 8133 8134 --------------------------------------- 8135 -- Expand_N_Delay_Relative_Statement -- 8136 --------------------------------------- 8137 8138 -- Delay statement is implemented as a procedure call to Delay_For 8139 -- defined in Ada.Calendar.Delays in order to reduce the overhead of 8140 -- simple delays imposed by the use of Protected Objects. 8141 8142 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is 8143 Loc : constant Source_Ptr := Sloc (N); 8144 Proc : Entity_Id; 8145 8146 begin 8147 -- Try to use Ada.Calendar.Delays.Delay_For if available. 8148 8149 if RTE_Available (RO_CA_Delay_For) then 8150 Proc := RTE (RO_CA_Delay_For); 8151 8152 -- Otherwise, use System.Relative_Delays.Delay_For and emit an error 8153 -- message if not available. This is the implementation used on 8154 -- restricted platforms when Ada.Calendar is not available. 8155 8156 else 8157 Proc := RTE (RO_RD_Delay_For); 8158 end if; 8159 8160 Rewrite (N, 8161 Make_Procedure_Call_Statement (Loc, 8162 Name => New_Occurrence_Of (Proc, Loc), 8163 Parameter_Associations => New_List (Expression (N)))); 8164 Analyze (N); 8165 end Expand_N_Delay_Relative_Statement; 8166 8167 ------------------------------------ 8168 -- Expand_N_Delay_Until_Statement -- 8169 ------------------------------------ 8170 8171 -- Delay Until statement is implemented as a procedure call to 8172 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays. 8173 8174 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is 8175 Loc : constant Source_Ptr := Sloc (N); 8176 Typ : Entity_Id; 8177 8178 begin 8179 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then 8180 Typ := RTE (RO_CA_Delay_Until); 8181 else 8182 Typ := RTE (RO_RT_Delay_Until); 8183 end if; 8184 8185 Rewrite (N, 8186 Make_Procedure_Call_Statement (Loc, 8187 Name => New_Occurrence_Of (Typ, Loc), 8188 Parameter_Associations => New_List (Expression (N)))); 8189 8190 Analyze (N); 8191 end Expand_N_Delay_Until_Statement; 8192 8193 ------------------------- 8194 -- Expand_N_Entry_Body -- 8195 ------------------------- 8196 8197 procedure Expand_N_Entry_Body (N : Node_Id) is 8198 begin 8199 -- Associate discriminals with the next protected operation body to be 8200 -- expanded. 8201 8202 if Present (Next_Protected_Operation (N)) then 8203 Set_Discriminals (Parent (Current_Scope)); 8204 end if; 8205 end Expand_N_Entry_Body; 8206 8207 ----------------------------------- 8208 -- Expand_N_Entry_Call_Statement -- 8209 ----------------------------------- 8210 8211 -- An entry call is expanded into GNARLI calls to implement a simple entry 8212 -- call (see Build_Simple_Entry_Call). 8213 8214 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is 8215 Concval : Node_Id; 8216 Ename : Node_Id; 8217 Index : Node_Id; 8218 8219 begin 8220 if No_Run_Time_Mode then 8221 Error_Msg_CRT ("entry call", N); 8222 return; 8223 end if; 8224 8225 -- If this entry call is part of an asynchronous select, don't expand it 8226 -- here; it will be expanded with the select statement. Don't expand 8227 -- timed entry calls either, as they are translated into asynchronous 8228 -- entry calls. 8229 8230 -- ??? This whole approach is questionable; it may be better to go back 8231 -- to allowing the expansion to take place and then attempting to fix it 8232 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out 8233 -- whether the expanded call is on a task or protected entry. 8234 8235 if (Nkind (Parent (N)) /= N_Triggering_Alternative 8236 or else N /= Triggering_Statement (Parent (N))) 8237 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative 8238 or else N /= Entry_Call_Statement (Parent (N)) 8239 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call) 8240 then 8241 Extract_Entry (N, Concval, Ename, Index); 8242 Build_Simple_Entry_Call (N, Concval, Ename, Index); 8243 end if; 8244 end Expand_N_Entry_Call_Statement; 8245 8246 -------------------------------- 8247 -- Expand_N_Entry_Declaration -- 8248 -------------------------------- 8249 8250 -- If there are parameters, then first, each of the formals is marked by 8251 -- setting Is_Entry_Formal. Next a record type is built which is used to 8252 -- hold the parameter values. The name of this record type is entryP where 8253 -- entry is the name of the entry, with an additional corresponding access 8254 -- type called entryPA. The record type has matching components for each 8255 -- formal (the component names are the same as the formal names). For 8256 -- elementary types, the component type matches the formal type. For 8257 -- composite types, an access type is declared (with the name formalA) 8258 -- which designates the formal type, and the type of the component is this 8259 -- access type. Finally the Entry_Component of each formal is set to 8260 -- reference the corresponding record component. 8261 8262 procedure Expand_N_Entry_Declaration (N : Node_Id) is 8263 Loc : constant Source_Ptr := Sloc (N); 8264 Entry_Ent : constant Entity_Id := Defining_Identifier (N); 8265 Components : List_Id; 8266 Formal : Node_Id; 8267 Ftype : Entity_Id; 8268 Last_Decl : Node_Id; 8269 Component : Entity_Id; 8270 Ctype : Entity_Id; 8271 Decl : Node_Id; 8272 Rec_Ent : Entity_Id; 8273 Acc_Ent : Entity_Id; 8274 8275 begin 8276 Formal := First_Formal (Entry_Ent); 8277 Last_Decl := N; 8278 8279 -- Most processing is done only if parameters are present 8280 8281 if Present (Formal) then 8282 Components := New_List; 8283 8284 -- Loop through formals 8285 8286 while Present (Formal) loop 8287 Set_Is_Entry_Formal (Formal); 8288 Component := 8289 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); 8290 Set_Entry_Component (Formal, Component); 8291 Set_Entry_Formal (Component, Formal); 8292 Ftype := Etype (Formal); 8293 8294 -- Declare new access type and then append 8295 8296 Ctype := Make_Temporary (Loc, 'A'); 8297 Set_Is_Param_Block_Component_Type (Ctype); 8298 8299 Decl := 8300 Make_Full_Type_Declaration (Loc, 8301 Defining_Identifier => Ctype, 8302 Type_Definition => 8303 Make_Access_To_Object_Definition (Loc, 8304 All_Present => True, 8305 Constant_Present => Ekind (Formal) = E_In_Parameter, 8306 Subtype_Indication => New_Occurrence_Of (Ftype, Loc))); 8307 8308 Insert_After (Last_Decl, Decl); 8309 Last_Decl := Decl; 8310 8311 Append_To (Components, 8312 Make_Component_Declaration (Loc, 8313 Defining_Identifier => Component, 8314 Component_Definition => 8315 Make_Component_Definition (Loc, 8316 Aliased_Present => False, 8317 Subtype_Indication => New_Occurrence_Of (Ctype, Loc)))); 8318 8319 Next_Formal_With_Extras (Formal); 8320 end loop; 8321 8322 -- Create the Entry_Parameter_Record declaration 8323 8324 Rec_Ent := Make_Temporary (Loc, 'P'); 8325 8326 Decl := 8327 Make_Full_Type_Declaration (Loc, 8328 Defining_Identifier => Rec_Ent, 8329 Type_Definition => 8330 Make_Record_Definition (Loc, 8331 Component_List => 8332 Make_Component_List (Loc, 8333 Component_Items => Components))); 8334 8335 Insert_After (Last_Decl, Decl); 8336 Last_Decl := Decl; 8337 8338 -- Construct and link in the corresponding access type 8339 8340 Acc_Ent := Make_Temporary (Loc, 'A'); 8341 8342 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); 8343 8344 Decl := 8345 Make_Full_Type_Declaration (Loc, 8346 Defining_Identifier => Acc_Ent, 8347 Type_Definition => 8348 Make_Access_To_Object_Definition (Loc, 8349 All_Present => True, 8350 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc))); 8351 8352 Insert_After (Last_Decl, Decl); 8353 end if; 8354 end Expand_N_Entry_Declaration; 8355 8356 ----------------------------- 8357 -- Expand_N_Protected_Body -- 8358 ----------------------------- 8359 8360 -- Protected bodies are expanded to the completion of the subprograms 8361 -- created for the corresponding protected type. These are a protected and 8362 -- unprotected version of each protected subprogram in the object, a 8363 -- function to calculate each entry barrier, and a procedure to execute the 8364 -- sequence of statements of each protected entry body. For example, for 8365 -- protected type ptype: 8366 8367 -- function entB 8368 -- (O : System.Address; 8369 -- E : Protected_Entry_Index) 8370 -- return Boolean 8371 -- is 8372 -- <discriminant renamings> 8373 -- <private object renamings> 8374 -- begin 8375 -- return <barrier expression>; 8376 -- end entB; 8377 8378 -- procedure pprocN (_object : in out poV;...) is 8379 -- <discriminant renamings> 8380 -- <private object renamings> 8381 -- begin 8382 -- <sequence of statements> 8383 -- end pprocN; 8384 8385 -- procedure pprocP (_object : in out poV;...) is 8386 -- procedure _clean is 8387 -- Pn : Boolean; 8388 -- begin 8389 -- ptypeS (_object, Pn); 8390 -- Unlock (_object._object'Access); 8391 -- Abort_Undefer.all; 8392 -- end _clean; 8393 8394 -- begin 8395 -- Abort_Defer.all; 8396 -- Lock (_object._object'Access); 8397 -- pprocN (_object;...); 8398 -- at end 8399 -- _clean; 8400 -- end pproc; 8401 8402 -- function pfuncN (_object : poV;...) return Return_Type is 8403 -- <discriminant renamings> 8404 -- <private object renamings> 8405 -- begin 8406 -- <sequence of statements> 8407 -- end pfuncN; 8408 8409 -- function pfuncP (_object : poV) return Return_Type is 8410 -- procedure _clean is 8411 -- begin 8412 -- Unlock (_object._object'Access); 8413 -- Abort_Undefer.all; 8414 -- end _clean; 8415 8416 -- begin 8417 -- Abort_Defer.all; 8418 -- Lock (_object._object'Access); 8419 -- return pfuncN (_object); 8420 8421 -- at end 8422 -- _clean; 8423 -- end pfunc; 8424 8425 -- procedure entE 8426 -- (O : System.Address; 8427 -- P : System.Address; 8428 -- E : Protected_Entry_Index) 8429 -- is 8430 -- <discriminant renamings> 8431 -- <private object renamings> 8432 -- type poVP is access poV; 8433 -- _Object : ptVP := ptVP!(O); 8434 8435 -- begin 8436 -- begin 8437 -- <statement sequence> 8438 -- Complete_Entry_Body (_Object._Object); 8439 -- exception 8440 -- when all others => 8441 -- Exceptional_Complete_Entry_Body ( 8442 -- _Object._Object, Get_GNAT_Exception); 8443 -- end; 8444 -- end entE; 8445 8446 -- The type poV is the record created for the protected type to hold 8447 -- the state of the protected object. 8448 8449 procedure Expand_N_Protected_Body (N : Node_Id) is 8450 Loc : constant Source_Ptr := Sloc (N); 8451 Pid : constant Entity_Id := Corresponding_Spec (N); 8452 8453 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid); 8454 -- This flag indicates whether the lock free implementation is active 8455 8456 Current_Node : Node_Id; 8457 Disp_Op_Body : Node_Id; 8458 New_Op_Body : Node_Id; 8459 Op_Body : Node_Id; 8460 Op_Id : Entity_Id; 8461 8462 function Build_Dispatching_Subprogram_Body 8463 (N : Node_Id; 8464 Pid : Node_Id; 8465 Prot_Bod : Node_Id) return Node_Id; 8466 -- Build a dispatching version of the protected subprogram body. The 8467 -- newly generated subprogram contains a call to the original protected 8468 -- body. The following code is generated: 8469 -- 8470 -- function <protected-function-name> (Param1 .. ParamN) return 8471 -- <return-type> is 8472 -- begin 8473 -- return <protected-function-name>P (Param1 .. ParamN); 8474 -- end <protected-function-name>; 8475 -- 8476 -- or 8477 -- 8478 -- procedure <protected-procedure-name> (Param1 .. ParamN) is 8479 -- begin 8480 -- <protected-procedure-name>P (Param1 .. ParamN); 8481 -- end <protected-procedure-name> 8482 8483 --------------------------------------- 8484 -- Build_Dispatching_Subprogram_Body -- 8485 --------------------------------------- 8486 8487 function Build_Dispatching_Subprogram_Body 8488 (N : Node_Id; 8489 Pid : Node_Id; 8490 Prot_Bod : Node_Id) return Node_Id 8491 is 8492 Loc : constant Source_Ptr := Sloc (N); 8493 Actuals : List_Id; 8494 Formal : Node_Id; 8495 Spec : Node_Id; 8496 Stmts : List_Id; 8497 8498 begin 8499 -- Generate a specification without a letter suffix in order to 8500 -- override an interface function or procedure. 8501 8502 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode); 8503 8504 -- The formal parameters become the actuals of the protected function 8505 -- or procedure call. 8506 8507 Actuals := New_List; 8508 Formal := First (Parameter_Specifications (Spec)); 8509 while Present (Formal) loop 8510 Append_To (Actuals, 8511 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 8512 Next (Formal); 8513 end loop; 8514 8515 if Nkind (Spec) = N_Procedure_Specification then 8516 Stmts := 8517 New_List ( 8518 Make_Procedure_Call_Statement (Loc, 8519 Name => 8520 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8521 Parameter_Associations => Actuals)); 8522 8523 else 8524 pragma Assert (Nkind (Spec) = N_Function_Specification); 8525 8526 Stmts := 8527 New_List ( 8528 Make_Simple_Return_Statement (Loc, 8529 Expression => 8530 Make_Function_Call (Loc, 8531 Name => 8532 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8533 Parameter_Associations => Actuals))); 8534 end if; 8535 8536 return 8537 Make_Subprogram_Body (Loc, 8538 Declarations => Empty_List, 8539 Specification => Spec, 8540 Handled_Statement_Sequence => 8541 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 8542 end Build_Dispatching_Subprogram_Body; 8543 8544 -- Start of processing for Expand_N_Protected_Body 8545 8546 begin 8547 if No_Run_Time_Mode then 8548 Error_Msg_CRT ("protected body", N); 8549 return; 8550 end if; 8551 8552 -- This is the proper body corresponding to a stub. The declarations 8553 -- must be inserted at the point of the stub, which in turn is in the 8554 -- declarative part of the parent unit. 8555 8556 if Nkind (Parent (N)) = N_Subunit then 8557 Current_Node := Corresponding_Stub (Parent (N)); 8558 else 8559 Current_Node := N; 8560 end if; 8561 8562 Op_Body := First (Declarations (N)); 8563 8564 -- The protected body is replaced with the bodies of its protected 8565 -- operations, and the declarations for internal objects that may 8566 -- have been created for entry family bounds. 8567 8568 Rewrite (N, Make_Null_Statement (Sloc (N))); 8569 Analyze (N); 8570 8571 while Present (Op_Body) loop 8572 case Nkind (Op_Body) is 8573 when N_Subprogram_Declaration => 8574 null; 8575 8576 when N_Subprogram_Body => 8577 8578 -- Do not create bodies for eliminated operations 8579 8580 if not Is_Eliminated (Defining_Entity (Op_Body)) 8581 and then not Is_Eliminated (Corresponding_Spec (Op_Body)) 8582 then 8583 if Lock_Free_Active then 8584 New_Op_Body := 8585 Build_Lock_Free_Unprotected_Subprogram_Body 8586 (Op_Body, Pid); 8587 else 8588 New_Op_Body := 8589 Build_Unprotected_Subprogram_Body (Op_Body, Pid); 8590 end if; 8591 8592 Insert_After (Current_Node, New_Op_Body); 8593 Current_Node := New_Op_Body; 8594 Analyze (New_Op_Body); 8595 8596 -- Build the corresponding protected operation. It may 8597 -- appear that this is needed only if this is a visible 8598 -- operation of the type, or if it is an interrupt handler, 8599 -- and this was the strategy used previously in GNAT. 8600 8601 -- However, the operation may be exported through a 'Access 8602 -- to an external caller. This is the common idiom in code 8603 -- that uses the Ada 2005 Timing_Events package. As a result 8604 -- we need to produce the protected body for both visible 8605 -- and private operations, as well as operations that only 8606 -- have a body in the source, and for which we create a 8607 -- declaration in the protected body itself. 8608 8609 if Present (Corresponding_Spec (Op_Body)) then 8610 if Lock_Free_Active then 8611 New_Op_Body := 8612 Build_Lock_Free_Protected_Subprogram_Body 8613 (Op_Body, Pid, Specification (New_Op_Body)); 8614 else 8615 New_Op_Body := 8616 Build_Protected_Subprogram_Body 8617 (Op_Body, Pid, Specification (New_Op_Body)); 8618 end if; 8619 8620 Insert_After (Current_Node, New_Op_Body); 8621 Analyze (New_Op_Body); 8622 8623 Current_Node := New_Op_Body; 8624 8625 -- Generate an overriding primitive operation body for 8626 -- this subprogram if the protected type implements an 8627 -- interface. 8628 8629 if Ada_Version >= Ada_2005 8630 and then 8631 Present (Interfaces (Corresponding_Record_Type (Pid))) 8632 then 8633 Disp_Op_Body := 8634 Build_Dispatching_Subprogram_Body 8635 (Op_Body, Pid, New_Op_Body); 8636 8637 Insert_After (Current_Node, Disp_Op_Body); 8638 Analyze (Disp_Op_Body); 8639 8640 Current_Node := Disp_Op_Body; 8641 end if; 8642 end if; 8643 end if; 8644 8645 when N_Entry_Body => 8646 Op_Id := Defining_Identifier (Op_Body); 8647 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); 8648 8649 Insert_After (Current_Node, New_Op_Body); 8650 Current_Node := New_Op_Body; 8651 Analyze (New_Op_Body); 8652 8653 when N_Implicit_Label_Declaration => 8654 null; 8655 8656 when N_Itype_Reference => 8657 Insert_After (Current_Node, New_Copy (Op_Body)); 8658 8659 when N_Freeze_Entity => 8660 New_Op_Body := New_Copy (Op_Body); 8661 8662 if Present (Entity (Op_Body)) 8663 and then Freeze_Node (Entity (Op_Body)) = Op_Body 8664 then 8665 Set_Freeze_Node (Entity (Op_Body), New_Op_Body); 8666 end if; 8667 8668 Insert_After (Current_Node, New_Op_Body); 8669 Current_Node := New_Op_Body; 8670 Analyze (New_Op_Body); 8671 8672 when N_Pragma => 8673 New_Op_Body := New_Copy (Op_Body); 8674 Insert_After (Current_Node, New_Op_Body); 8675 Current_Node := New_Op_Body; 8676 Analyze (New_Op_Body); 8677 8678 when N_Object_Declaration => 8679 pragma Assert (not Comes_From_Source (Op_Body)); 8680 New_Op_Body := New_Copy (Op_Body); 8681 Insert_After (Current_Node, New_Op_Body); 8682 Current_Node := New_Op_Body; 8683 Analyze (New_Op_Body); 8684 8685 when others => 8686 raise Program_Error; 8687 end case; 8688 8689 Next (Op_Body); 8690 end loop; 8691 8692 -- Finally, create the body of the function that maps an entry index 8693 -- into the corresponding body index, except when there is no entry, or 8694 -- in a Ravenscar-like profile. 8695 8696 if Corresponding_Runtime_Package (Pid) = 8697 System_Tasking_Protected_Objects_Entries 8698 then 8699 New_Op_Body := Build_Find_Body_Index (Pid); 8700 Insert_After (Current_Node, New_Op_Body); 8701 Current_Node := New_Op_Body; 8702 Analyze (New_Op_Body); 8703 end if; 8704 8705 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the 8706 -- protected body. At this point all wrapper specs have been created, 8707 -- frozen and included in the dispatch table for the protected type. 8708 8709 if Ada_Version >= Ada_2005 then 8710 Build_Wrapper_Bodies (Loc, Pid, Current_Node); 8711 end if; 8712 end Expand_N_Protected_Body; 8713 8714 ----------------------------------------- 8715 -- Expand_N_Protected_Type_Declaration -- 8716 ----------------------------------------- 8717 8718 -- First we create a corresponding record type declaration used to 8719 -- represent values of this protected type. 8720 -- The general form of this type declaration is 8721 8722 -- type poV (discriminants) is record 8723 -- _Object : aliased <kind>Protection 8724 -- [(<entry count> [, <handler count>])]; 8725 -- [entry_family : array (bounds) of Void;] 8726 -- <private data fields> 8727 -- end record; 8728 8729 -- The discriminants are present only if the corresponding protected type 8730 -- has discriminants, and they exactly mirror the protected type 8731 -- discriminants. The private data fields similarly mirror the private 8732 -- declarations of the protected type. 8733 8734 -- The Object field is always present. It contains RTS specific data used 8735 -- to control the protected object. It is declared as Aliased so that it 8736 -- can be passed as a pointer to the RTS. This allows the protected record 8737 -- to be referenced within RTS data structures. An appropriate Protection 8738 -- type and discriminant are generated. 8739 8740 -- The Service field is present for protected objects with entries. It 8741 -- contains sufficient information to allow the entry service procedure for 8742 -- this object to be called when the object is not known till runtime. 8743 8744 -- One entry_family component is present for each entry family in the 8745 -- task definition (see Expand_N_Task_Type_Declaration). 8746 8747 -- When a protected object is declared, an instance of the protected type 8748 -- value record is created. The elaboration of this declaration creates the 8749 -- correct bounds for the entry families, and also evaluates the priority 8750 -- expression if needed. The initialization routine for the protected type 8751 -- itself then calls Initialize_Protection with appropriate parameters to 8752 -- initialize the value of the Task_Id field. Install_Handlers may be also 8753 -- called if a pragma Attach_Handler applies. 8754 8755 -- Note: this record is passed to the subprograms created by the expansion 8756 -- of protected subprograms and entries. It is an in parameter to protected 8757 -- functions and an in out parameter to procedures and entry bodies. The 8758 -- Entity_Id for this created record type is placed in the 8759 -- Corresponding_Record_Type field of the associated protected type entity. 8760 8761 -- Next we create a procedure specifications for protected subprograms and 8762 -- entry bodies. For each protected subprograms two subprograms are 8763 -- created, an unprotected and a protected version. The unprotected version 8764 -- is called from within other operations of the same protected object. 8765 8766 -- We also build the call to register the procedure if a pragma 8767 -- Interrupt_Handler applies. 8768 8769 -- A single subprogram is created to service all entry bodies; it has an 8770 -- additional boolean out parameter indicating that the previous entry call 8771 -- made by the current task was serviced immediately, i.e. not by proxy. 8772 -- The O parameter contains a pointer to a record object of the type 8773 -- described above. An untyped interface is used here to allow this 8774 -- procedure to be called in places where the type of the object to be 8775 -- serviced is not known. This must be done, for example, when a call that 8776 -- may have been requeued is cancelled; the corresponding object must be 8777 -- serviced, but which object that is not known till runtime. 8778 8779 -- procedure ptypeS 8780 -- (O : System.Address; P : out Boolean); 8781 -- procedure pprocN (_object : in out poV); 8782 -- procedure pproc (_object : in out poV); 8783 -- function pfuncN (_object : poV); 8784 -- function pfunc (_object : poV); 8785 -- ... 8786 8787 -- Note that this must come after the record type declaration, since 8788 -- the specs refer to this type. 8789 8790 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is 8791 Discr_Map : constant Elist_Id := New_Elmt_List; 8792 Loc : constant Source_Ptr := Sloc (N); 8793 Prot_Typ : constant Entity_Id := Defining_Identifier (N); 8794 8795 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ); 8796 -- This flag indicates whether the lock free implementation is active 8797 8798 Pdef : constant Node_Id := Protected_Definition (N); 8799 -- This contains two lists; one for visible and one for private decls 8800 8801 Current_Node : Node_Id := N; 8802 E_Count : Int; 8803 Entries_Aggr : Node_Id; 8804 8805 procedure Check_Inlining (Subp : Entity_Id); 8806 -- If the original operation has a pragma Inline, propagate the flag 8807 -- to the internal body, for possible inlining later on. The source 8808 -- operation is invisible to the back-end and is never actually called. 8809 8810 procedure Expand_Entry_Declaration (Decl : Node_Id); 8811 -- Create the entry barrier and the procedure body for entry declaration 8812 -- Decl. All generated subprograms are added to Entry_Bodies_Array. 8813 8814 function Static_Component_Size (Comp : Entity_Id) return Boolean; 8815 -- When compiling under the Ravenscar profile, private components must 8816 -- have a static size, or else a protected object will require heap 8817 -- allocation, violating the corresponding restriction. It is preferable 8818 -- to make this check here, because it provides a better error message 8819 -- than the back-end, which refers to the object as a whole. 8820 8821 procedure Register_Handler; 8822 -- For a protected operation that is an interrupt handler, add the 8823 -- freeze action that will register it as such. 8824 8825 -------------------- 8826 -- Check_Inlining -- 8827 -------------------- 8828 8829 procedure Check_Inlining (Subp : Entity_Id) is 8830 begin 8831 if Is_Inlined (Subp) then 8832 Set_Is_Inlined (Protected_Body_Subprogram (Subp)); 8833 Set_Is_Inlined (Subp, False); 8834 end if; 8835 end Check_Inlining; 8836 8837 --------------------------- 8838 -- Static_Component_Size -- 8839 --------------------------- 8840 8841 function Static_Component_Size (Comp : Entity_Id) return Boolean is 8842 Typ : constant Entity_Id := Etype (Comp); 8843 C : Entity_Id; 8844 8845 begin 8846 if Is_Scalar_Type (Typ) then 8847 return True; 8848 8849 elsif Is_Array_Type (Typ) then 8850 return Compile_Time_Known_Bounds (Typ); 8851 8852 elsif Is_Record_Type (Typ) then 8853 C := First_Component (Typ); 8854 while Present (C) loop 8855 if not Static_Component_Size (C) then 8856 return False; 8857 end if; 8858 8859 Next_Component (C); 8860 end loop; 8861 8862 return True; 8863 8864 -- Any other type will be checked by the back-end 8865 8866 else 8867 return True; 8868 end if; 8869 end Static_Component_Size; 8870 8871 ------------------------------ 8872 -- Expand_Entry_Declaration -- 8873 ------------------------------ 8874 8875 procedure Expand_Entry_Declaration (Decl : Node_Id) is 8876 Ent_Id : constant Entity_Id := Defining_Entity (Decl); 8877 Bar_Id : Entity_Id; 8878 Bod_Id : Entity_Id; 8879 Subp : Node_Id; 8880 8881 begin 8882 E_Count := E_Count + 1; 8883 8884 -- Create the protected body subprogram 8885 8886 Bod_Id := 8887 Make_Defining_Identifier (Loc, 8888 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E')); 8889 Set_Protected_Body_Subprogram (Ent_Id, Bod_Id); 8890 8891 Subp := 8892 Make_Subprogram_Declaration (Loc, 8893 Specification => 8894 Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id)); 8895 8896 Insert_After (Current_Node, Subp); 8897 Current_Node := Subp; 8898 8899 Analyze (Subp); 8900 8901 -- Build a wrapper procedure to handle contract cases, preconditions, 8902 -- and postconditions. 8903 8904 Build_Contract_Wrapper (Ent_Id, N); 8905 8906 -- Create the barrier function 8907 8908 Bar_Id := 8909 Make_Defining_Identifier (Loc, 8910 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B')); 8911 Set_Barrier_Function (Ent_Id, Bar_Id); 8912 8913 Subp := 8914 Make_Subprogram_Declaration (Loc, 8915 Specification => 8916 Build_Barrier_Function_Specification (Loc, Bar_Id)); 8917 Set_Is_Entry_Barrier_Function (Subp); 8918 8919 Insert_After (Current_Node, Subp); 8920 Current_Node := Subp; 8921 8922 Analyze (Subp); 8923 8924 Set_Protected_Body_Subprogram (Bar_Id, Bar_Id); 8925 Set_Scope (Bar_Id, Scope (Ent_Id)); 8926 8927 -- Collect pointers to the protected subprogram and the barrier 8928 -- of the current entry, for insertion into Entry_Bodies_Array. 8929 8930 Append_To (Expressions (Entries_Aggr), 8931 Make_Aggregate (Loc, 8932 Expressions => New_List ( 8933 Make_Attribute_Reference (Loc, 8934 Prefix => New_Occurrence_Of (Bar_Id, Loc), 8935 Attribute_Name => Name_Unrestricted_Access), 8936 Make_Attribute_Reference (Loc, 8937 Prefix => New_Occurrence_Of (Bod_Id, Loc), 8938 Attribute_Name => Name_Unrestricted_Access)))); 8939 end Expand_Entry_Declaration; 8940 8941 ---------------------- 8942 -- Register_Handler -- 8943 ---------------------- 8944 8945 procedure Register_Handler is 8946 8947 -- All semantic checks already done in Sem_Prag 8948 8949 Prot_Proc : constant Entity_Id := 8950 Defining_Unit_Name (Specification (Current_Node)); 8951 8952 Proc_Address : constant Node_Id := 8953 Make_Attribute_Reference (Loc, 8954 Prefix => 8955 New_Occurrence_Of (Prot_Proc, Loc), 8956 Attribute_Name => Name_Address); 8957 8958 RTS_Call : constant Entity_Id := 8959 Make_Procedure_Call_Statement (Loc, 8960 Name => 8961 New_Occurrence_Of 8962 (RTE (RE_Register_Interrupt_Handler), Loc), 8963 Parameter_Associations => New_List (Proc_Address)); 8964 begin 8965 Append_Freeze_Action (Prot_Proc, RTS_Call); 8966 end Register_Handler; 8967 8968 -- Local variables 8969 8970 Body_Arr : Node_Id; 8971 Body_Id : Entity_Id; 8972 Cdecls : List_Id; 8973 Comp : Node_Id; 8974 Expr : Node_Id; 8975 New_Priv : Node_Id; 8976 Obj_Def : Node_Id; 8977 Object_Comp : Node_Id; 8978 Priv : Node_Id; 8979 Rec_Decl : Node_Id; 8980 Sub : Node_Id; 8981 8982 -- Start of processing for Expand_N_Protected_Type_Declaration 8983 8984 begin 8985 if Present (Corresponding_Record_Type (Prot_Typ)) then 8986 return; 8987 else 8988 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); 8989 end if; 8990 8991 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); 8992 8993 Qualify_Entity_Names (N); 8994 8995 -- If the type has discriminants, their occurrences in the declaration 8996 -- have been replaced by the corresponding discriminals. For components 8997 -- that are constrained by discriminants, their homologues in the 8998 -- corresponding record type must refer to the discriminants of that 8999 -- record, so we must apply a new renaming to subtypes_indications: 9000 9001 -- protected discriminant => discriminal => record discriminant 9002 9003 -- This replacement is not applied to default expressions, for which 9004 -- the discriminal is correct. 9005 9006 if Has_Discriminants (Prot_Typ) then 9007 declare 9008 Disc : Entity_Id; 9009 Decl : Node_Id; 9010 9011 begin 9012 Disc := First_Discriminant (Prot_Typ); 9013 Decl := First (Discriminant_Specifications (Rec_Decl)); 9014 while Present (Disc) loop 9015 Append_Elmt (Discriminal (Disc), Discr_Map); 9016 Append_Elmt (Defining_Identifier (Decl), Discr_Map); 9017 Next_Discriminant (Disc); 9018 Next (Decl); 9019 end loop; 9020 end; 9021 end if; 9022 9023 -- Fill in the component declarations 9024 9025 -- Add components for entry families. For each entry family, create an 9026 -- anonymous type declaration with the same size, and analyze the type. 9027 9028 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); 9029 9030 pragma Assert (Present (Pdef)); 9031 9032 Insert_After (Current_Node, Rec_Decl); 9033 Current_Node := Rec_Decl; 9034 9035 -- Add private field components 9036 9037 if Present (Private_Declarations (Pdef)) then 9038 Priv := First (Private_Declarations (Pdef)); 9039 while Present (Priv) loop 9040 if Nkind (Priv) = N_Component_Declaration then 9041 if not Static_Component_Size (Defining_Identifier (Priv)) then 9042 9043 -- When compiling for a restricted profile, the private 9044 -- components must have a static size. If not, this is an 9045 -- error for a single protected declaration, and rates a 9046 -- warning on a protected type declaration. 9047 9048 if not Comes_From_Source (Prot_Typ) then 9049 9050 -- It's ok to be checking this restriction at expansion 9051 -- time, because this is only for the restricted profile, 9052 -- which is not subject to strict RM conformance, so it 9053 -- is OK to miss this check in -gnatc mode. 9054 9055 Check_Restriction (No_Implicit_Heap_Allocations, Priv); 9056 Check_Restriction 9057 (No_Implicit_Protected_Object_Allocations, Priv); 9058 9059 elsif Restriction_Active (No_Implicit_Heap_Allocations) then 9060 if not Discriminated_Size (Defining_Identifier (Priv)) 9061 then 9062 -- Any object of the type will be non-static 9063 9064 Error_Msg_N ("component has non-static size??", Priv); 9065 Error_Msg_NE 9066 ("\creation of protected object of type& will " 9067 & "violate restriction " 9068 & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ); 9069 else 9070 -- Object will be non-static if discriminants are 9071 9072 Error_Msg_NE 9073 ("creation of protected object of type& with " 9074 & "non-static discriminants will violate " 9075 & "restriction No_Implicit_Heap_Allocations??", 9076 Priv, Prot_Typ); 9077 end if; 9078 9079 -- Likewise for No_Implicit_Protected_Object_Allocations 9080 9081 elsif Restriction_Active 9082 (No_Implicit_Protected_Object_Allocations) 9083 then 9084 if not Discriminated_Size (Defining_Identifier (Priv)) 9085 then 9086 -- Any object of the type will be non-static 9087 9088 Error_Msg_N ("component has non-static size??", Priv); 9089 Error_Msg_NE 9090 ("\creation of protected object of type& will " 9091 & "violate restriction " 9092 & "No_Implicit_Protected_Object_Allocations??", 9093 Priv, Prot_Typ); 9094 else 9095 -- Object will be non-static if discriminants are 9096 9097 Error_Msg_NE 9098 ("creation of protected object of type& with " 9099 & "non-static discriminants will violate " 9100 & "restriction " 9101 & "No_Implicit_Protected_Object_Allocations??", 9102 Priv, Prot_Typ); 9103 end if; 9104 end if; 9105 end if; 9106 9107 -- The component definition consists of a subtype indication, 9108 -- or (in Ada 2005) an access definition. Make a copy of the 9109 -- proper definition. 9110 9111 declare 9112 Old_Comp : constant Node_Id := Component_Definition (Priv); 9113 Oent : constant Entity_Id := Defining_Identifier (Priv); 9114 Nent : constant Entity_Id := 9115 Make_Defining_Identifier (Sloc (Oent), 9116 Chars => Chars (Oent)); 9117 New_Comp : Node_Id; 9118 9119 begin 9120 if Present (Subtype_Indication (Old_Comp)) then 9121 New_Comp := 9122 Make_Component_Definition (Sloc (Oent), 9123 Aliased_Present => False, 9124 Subtype_Indication => 9125 New_Copy_Tree 9126 (Subtype_Indication (Old_Comp), Discr_Map)); 9127 else 9128 New_Comp := 9129 Make_Component_Definition (Sloc (Oent), 9130 Aliased_Present => False, 9131 Access_Definition => 9132 New_Copy_Tree 9133 (Access_Definition (Old_Comp), Discr_Map)); 9134 end if; 9135 9136 New_Priv := 9137 Make_Component_Declaration (Loc, 9138 Defining_Identifier => Nent, 9139 Component_Definition => New_Comp, 9140 Expression => Expression (Priv)); 9141 9142 Set_Has_Per_Object_Constraint (Nent, 9143 Has_Per_Object_Constraint (Oent)); 9144 9145 Append_To (Cdecls, New_Priv); 9146 end; 9147 9148 elsif Nkind (Priv) = N_Subprogram_Declaration then 9149 9150 -- Make the unprotected version of the subprogram available 9151 -- for expansion of intra object calls. There is need for 9152 -- a protected version only if the subprogram is an interrupt 9153 -- handler, otherwise this operation can only be called from 9154 -- within the body. 9155 9156 Sub := 9157 Make_Subprogram_Declaration (Loc, 9158 Specification => 9159 Build_Protected_Sub_Specification 9160 (Priv, Prot_Typ, Unprotected_Mode)); 9161 9162 Insert_After (Current_Node, Sub); 9163 Analyze (Sub); 9164 9165 Set_Protected_Body_Subprogram 9166 (Defining_Unit_Name (Specification (Priv)), 9167 Defining_Unit_Name (Specification (Sub))); 9168 Check_Inlining (Defining_Unit_Name (Specification (Priv))); 9169 Current_Node := Sub; 9170 9171 Sub := 9172 Make_Subprogram_Declaration (Loc, 9173 Specification => 9174 Build_Protected_Sub_Specification 9175 (Priv, Prot_Typ, Protected_Mode)); 9176 9177 Insert_After (Current_Node, Sub); 9178 Analyze (Sub); 9179 Current_Node := Sub; 9180 9181 if Is_Interrupt_Handler 9182 (Defining_Unit_Name (Specification (Priv))) 9183 then 9184 if not Restricted_Profile then 9185 Register_Handler; 9186 end if; 9187 end if; 9188 end if; 9189 9190 Next (Priv); 9191 end loop; 9192 end if; 9193 9194 -- Except for the lock-free implementation, append the _Object field 9195 -- with the right type to the component list. We need to compute the 9196 -- number of entries, and in some cases the number of Attach_Handler 9197 -- pragmas. 9198 9199 if not Lock_Free_Active then 9200 declare 9201 Entry_Count_Expr : constant Node_Id := 9202 Build_Entry_Count_Expression 9203 (Prot_Typ, Cdecls, Loc); 9204 Num_Attach_Handler : Nat := 0; 9205 Protection_Subtype : Node_Id; 9206 Ritem : Node_Id; 9207 9208 begin 9209 if Has_Attach_Handler (Prot_Typ) then 9210 Ritem := First_Rep_Item (Prot_Typ); 9211 while Present (Ritem) loop 9212 if Nkind (Ritem) = N_Pragma 9213 and then Pragma_Name (Ritem) = Name_Attach_Handler 9214 then 9215 Num_Attach_Handler := Num_Attach_Handler + 1; 9216 end if; 9217 9218 Next_Rep_Item (Ritem); 9219 end loop; 9220 end if; 9221 9222 -- Determine the proper protection type. There are two special 9223 -- cases: 1) when the protected type has dynamic interrupt 9224 -- handlers, and 2) when it has static handlers and we use a 9225 -- restricted profile. 9226 9227 if Has_Attach_Handler (Prot_Typ) 9228 and then not Restricted_Profile 9229 then 9230 Protection_Subtype := 9231 Make_Subtype_Indication (Loc, 9232 Subtype_Mark => 9233 New_Occurrence_Of 9234 (RTE (RE_Static_Interrupt_Protection), Loc), 9235 Constraint => 9236 Make_Index_Or_Discriminant_Constraint (Loc, 9237 Constraints => New_List ( 9238 Entry_Count_Expr, 9239 Make_Integer_Literal (Loc, Num_Attach_Handler)))); 9240 9241 elsif Has_Interrupt_Handler (Prot_Typ) 9242 and then not Restriction_Active (No_Dynamic_Attachment) 9243 then 9244 Protection_Subtype := 9245 Make_Subtype_Indication (Loc, 9246 Subtype_Mark => 9247 New_Occurrence_Of 9248 (RTE (RE_Dynamic_Interrupt_Protection), Loc), 9249 Constraint => 9250 Make_Index_Or_Discriminant_Constraint (Loc, 9251 Constraints => New_List (Entry_Count_Expr))); 9252 9253 else 9254 case Corresponding_Runtime_Package (Prot_Typ) is 9255 when System_Tasking_Protected_Objects_Entries => 9256 Protection_Subtype := 9257 Make_Subtype_Indication (Loc, 9258 Subtype_Mark => 9259 New_Occurrence_Of 9260 (RTE (RE_Protection_Entries), Loc), 9261 Constraint => 9262 Make_Index_Or_Discriminant_Constraint (Loc, 9263 Constraints => New_List (Entry_Count_Expr))); 9264 9265 when System_Tasking_Protected_Objects_Single_Entry => 9266 Protection_Subtype := 9267 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc); 9268 9269 when System_Tasking_Protected_Objects => 9270 Protection_Subtype := 9271 New_Occurrence_Of (RTE (RE_Protection), Loc); 9272 9273 when others => 9274 raise Program_Error; 9275 end case; 9276 end if; 9277 9278 Object_Comp := 9279 Make_Component_Declaration (Loc, 9280 Defining_Identifier => 9281 Make_Defining_Identifier (Loc, Name_uObject), 9282 Component_Definition => 9283 Make_Component_Definition (Loc, 9284 Aliased_Present => True, 9285 Subtype_Indication => Protection_Subtype)); 9286 end; 9287 9288 -- Put the _Object component after the private component so that it 9289 -- be finalized early as required by 9.4 (20) 9290 9291 Append_To (Cdecls, Object_Comp); 9292 end if; 9293 9294 -- Analyze the record declaration immediately after construction, 9295 -- because the initialization procedure is needed for single object 9296 -- declarations before the next entity is analyzed (the freeze call 9297 -- that generates this initialization procedure is found below). 9298 9299 Analyze (Rec_Decl, Suppress => All_Checks); 9300 9301 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before 9302 -- the corresponding record is frozen. If any wrappers are generated, 9303 -- Current_Node is updated accordingly. 9304 9305 if Ada_Version >= Ada_2005 then 9306 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node); 9307 end if; 9308 9309 -- Collect pointers to entry bodies and their barriers, to be placed 9310 -- in the Entry_Bodies_Array for the type. For each entry/family we 9311 -- add an expression to the aggregate which is the initial value of 9312 -- this array. The array is declared after all protected subprograms. 9313 9314 if Has_Entries (Prot_Typ) then 9315 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); 9316 else 9317 Entries_Aggr := Empty; 9318 end if; 9319 9320 -- Build two new procedure specifications for each protected subprogram; 9321 -- one to call from outside the object and one to call from inside. 9322 -- Build a barrier function and an entry body action procedure 9323 -- specification for each protected entry. Initialize the entry body 9324 -- array. If subprogram is flagged as eliminated, do not generate any 9325 -- internal operations. 9326 9327 E_Count := 0; 9328 Comp := First (Visible_Declarations (Pdef)); 9329 while Present (Comp) loop 9330 if Nkind (Comp) = N_Subprogram_Declaration then 9331 Sub := 9332 Make_Subprogram_Declaration (Loc, 9333 Specification => 9334 Build_Protected_Sub_Specification 9335 (Comp, Prot_Typ, Unprotected_Mode)); 9336 9337 Insert_After (Current_Node, Sub); 9338 Analyze (Sub); 9339 9340 Set_Protected_Body_Subprogram 9341 (Defining_Unit_Name (Specification (Comp)), 9342 Defining_Unit_Name (Specification (Sub))); 9343 Check_Inlining (Defining_Unit_Name (Specification (Comp))); 9344 9345 -- Make the protected version of the subprogram available for 9346 -- expansion of external calls. 9347 9348 Current_Node := Sub; 9349 9350 Sub := 9351 Make_Subprogram_Declaration (Loc, 9352 Specification => 9353 Build_Protected_Sub_Specification 9354 (Comp, Prot_Typ, Protected_Mode)); 9355 9356 Insert_After (Current_Node, Sub); 9357 Analyze (Sub); 9358 9359 Current_Node := Sub; 9360 9361 -- Generate an overriding primitive operation specification for 9362 -- this subprogram if the protected type implements an interface 9363 -- and Build_Wrapper_Spec did not generate its wrapper. 9364 9365 if Ada_Version >= Ada_2005 9366 and then 9367 Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) 9368 then 9369 declare 9370 Found : Boolean := False; 9371 Prim_Elmt : Elmt_Id; 9372 Prim_Op : Node_Id; 9373 9374 begin 9375 Prim_Elmt := 9376 First_Elmt 9377 (Primitive_Operations 9378 (Corresponding_Record_Type (Prot_Typ))); 9379 9380 while Present (Prim_Elmt) loop 9381 Prim_Op := Node (Prim_Elmt); 9382 9383 if Is_Primitive_Wrapper (Prim_Op) 9384 and then Wrapped_Entity (Prim_Op) = 9385 Defining_Entity (Specification (Comp)) 9386 then 9387 Found := True; 9388 exit; 9389 end if; 9390 9391 Next_Elmt (Prim_Elmt); 9392 end loop; 9393 9394 if not Found then 9395 Sub := 9396 Make_Subprogram_Declaration (Loc, 9397 Specification => 9398 Build_Protected_Sub_Specification 9399 (Comp, Prot_Typ, Dispatching_Mode)); 9400 9401 Insert_After (Current_Node, Sub); 9402 Analyze (Sub); 9403 9404 Current_Node := Sub; 9405 end if; 9406 end; 9407 end if; 9408 9409 -- If a pragma Interrupt_Handler applies, build and add a call to 9410 -- Register_Interrupt_Handler to the freezing actions of the 9411 -- protected version (Current_Node) of the subprogram: 9412 9413 -- system.interrupts.register_interrupt_handler 9414 -- (prot_procP'address); 9415 9416 if not Restricted_Profile 9417 and then Is_Interrupt_Handler 9418 (Defining_Unit_Name (Specification (Comp))) 9419 then 9420 Register_Handler; 9421 end if; 9422 9423 elsif Nkind (Comp) = N_Entry_Declaration then 9424 Expand_Entry_Declaration (Comp); 9425 end if; 9426 9427 Next (Comp); 9428 end loop; 9429 9430 -- If there are some private entry declarations, expand it as if they 9431 -- were visible entries. 9432 9433 if Present (Private_Declarations (Pdef)) then 9434 Comp := First (Private_Declarations (Pdef)); 9435 while Present (Comp) loop 9436 if Nkind (Comp) = N_Entry_Declaration then 9437 Expand_Entry_Declaration (Comp); 9438 end if; 9439 9440 Next (Comp); 9441 end loop; 9442 end if; 9443 9444 -- Create the declaration of an array object which contains the values 9445 -- of aspect/pragma Max_Queue_Length for all entries of the protected 9446 -- type. This object is later passed to the appropriate protected object 9447 -- initialization routine. 9448 9449 if Has_Entries (Prot_Typ) 9450 and then Corresponding_Runtime_Package (Prot_Typ) = 9451 System_Tasking_Protected_Objects_Entries 9452 then 9453 declare 9454 Count : Int; 9455 Item : Entity_Id; 9456 Max_Vals : Node_Id; 9457 Maxes : List_Id; 9458 Maxes_Id : Entity_Id; 9459 Need_Array : Boolean := False; 9460 9461 begin 9462 -- First check if there is any Max_Queue_Length pragma 9463 9464 Item := First_Entity (Prot_Typ); 9465 while Present (Item) loop 9466 if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then 9467 Need_Array := True; 9468 exit; 9469 end if; 9470 9471 Next_Entity (Item); 9472 end loop; 9473 9474 -- Gather the Max_Queue_Length values of all entries in a list. A 9475 -- value of zero indicates that the entry has no limitation on its 9476 -- queue length. 9477 9478 if Need_Array then 9479 Count := 0; 9480 Item := First_Entity (Prot_Typ); 9481 Maxes := New_List; 9482 while Present (Item) loop 9483 if Is_Entry (Item) then 9484 Count := Count + 1; 9485 Append_To (Maxes, 9486 Make_Integer_Literal 9487 (Loc, Get_Max_Queue_Length (Item))); 9488 end if; 9489 9490 Next_Entity (Item); 9491 end loop; 9492 9493 -- Create the declaration of the array object. Generate: 9494 9495 -- Maxes_Id : aliased constant 9496 -- Protected_Entry_Queue_Max_Array 9497 -- (1 .. Count) := (..., ...); 9498 9499 Maxes_Id := 9500 Make_Defining_Identifier (Loc, 9501 Chars => New_External_Name (Chars (Prot_Typ), 'B')); 9502 9503 Max_Vals := 9504 Make_Object_Declaration (Loc, 9505 Defining_Identifier => Maxes_Id, 9506 Aliased_Present => True, 9507 Constant_Present => True, 9508 Object_Definition => 9509 Make_Subtype_Indication (Loc, 9510 Subtype_Mark => 9511 New_Occurrence_Of 9512 (RTE (RE_Protected_Entry_Queue_Max_Array), Loc), 9513 Constraint => 9514 Make_Index_Or_Discriminant_Constraint (Loc, 9515 Constraints => New_List ( 9516 Make_Range (Loc, 9517 Make_Integer_Literal (Loc, 1), 9518 Make_Integer_Literal (Loc, Count))))), 9519 Expression => Make_Aggregate (Loc, Maxes)); 9520 9521 -- A pointer to this array will be placed in the corresponding 9522 -- record by its initialization procedure so this needs to be 9523 -- analyzed here. 9524 9525 Insert_After (Current_Node, Max_Vals); 9526 Current_Node := Max_Vals; 9527 Analyze (Max_Vals); 9528 9529 Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxes_Id); 9530 end if; 9531 end; 9532 end if; 9533 9534 -- Emit declaration for Entry_Bodies_Array, now that the addresses of 9535 -- all protected subprograms have been collected. 9536 9537 if Has_Entries (Prot_Typ) then 9538 Body_Id := 9539 Make_Defining_Identifier (Sloc (Prot_Typ), 9540 Chars => New_External_Name (Chars (Prot_Typ), 'A')); 9541 9542 case Corresponding_Runtime_Package (Prot_Typ) is 9543 when System_Tasking_Protected_Objects_Entries => 9544 Expr := Entries_Aggr; 9545 Obj_Def := 9546 Make_Subtype_Indication (Loc, 9547 Subtype_Mark => 9548 New_Occurrence_Of 9549 (RTE (RE_Protected_Entry_Body_Array), Loc), 9550 Constraint => 9551 Make_Index_Or_Discriminant_Constraint (Loc, 9552 Constraints => New_List ( 9553 Make_Range (Loc, 9554 Make_Integer_Literal (Loc, 1), 9555 Make_Integer_Literal (Loc, E_Count))))); 9556 9557 when System_Tasking_Protected_Objects_Single_Entry => 9558 Expr := Remove_Head (Expressions (Entries_Aggr)); 9559 Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc); 9560 9561 when others => 9562 raise Program_Error; 9563 end case; 9564 9565 Body_Arr := 9566 Make_Object_Declaration (Loc, 9567 Defining_Identifier => Body_Id, 9568 Aliased_Present => True, 9569 Constant_Present => True, 9570 Object_Definition => Obj_Def, 9571 Expression => Expr); 9572 9573 -- A pointer to this array will be placed in the corresponding record 9574 -- by its initialization procedure so this needs to be analyzed here. 9575 9576 Insert_After (Current_Node, Body_Arr); 9577 Current_Node := Body_Arr; 9578 Analyze (Body_Arr); 9579 9580 Set_Entry_Bodies_Array (Prot_Typ, Body_Id); 9581 9582 -- Finally, build the function that maps an entry index into the 9583 -- corresponding body. A pointer to this function is placed in each 9584 -- object of the type. Except for a ravenscar-like profile (no abort, 9585 -- no entry queue, 1 entry) 9586 9587 if Corresponding_Runtime_Package (Prot_Typ) = 9588 System_Tasking_Protected_Objects_Entries 9589 then 9590 Sub := 9591 Make_Subprogram_Declaration (Loc, 9592 Specification => Build_Find_Body_Index_Spec (Prot_Typ)); 9593 9594 Insert_After (Current_Node, Sub); 9595 Analyze (Sub); 9596 end if; 9597 end if; 9598 end Expand_N_Protected_Type_Declaration; 9599 9600 -------------------------------- 9601 -- Expand_N_Requeue_Statement -- 9602 -------------------------------- 9603 9604 -- A nondispatching requeue statement is expanded into one of four GNARLI 9605 -- operations, depending on the source and destination (task or protected 9606 -- object). A dispatching requeue statement is expanded into a call to the 9607 -- predefined primitive _Disp_Requeue. In addition, code is generated to 9608 -- jump around the remainder of processing for the original entry and, if 9609 -- the destination is (different) protected object, to attempt to service 9610 -- it. The following illustrates the various cases: 9611 9612 -- procedure entE 9613 -- (O : System.Address; 9614 -- P : System.Address; 9615 -- E : Protected_Entry_Index) 9616 -- is 9617 -- <discriminant renamings> 9618 -- <private object renamings> 9619 -- type poVP is access poV; 9620 -- _object : ptVP := ptVP!(O); 9621 9622 -- begin 9623 -- begin 9624 -- <start of statement sequence for entry> 9625 9626 -- -- Requeue from one protected entry body to another protected 9627 -- -- entry. 9628 9629 -- Requeue_Protected_Entry ( 9630 -- _object._object'Access, 9631 -- new._object'Access, 9632 -- E, 9633 -- Abort_Present); 9634 -- return; 9635 9636 -- <some more of the statement sequence for entry> 9637 9638 -- -- Requeue from an entry body to a task entry 9639 9640 -- Requeue_Protected_To_Task_Entry ( 9641 -- New._task_id, 9642 -- E, 9643 -- Abort_Present); 9644 -- return; 9645 9646 -- <rest of statement sequence for entry> 9647 -- Complete_Entry_Body (_object._object); 9648 9649 -- exception 9650 -- when all others => 9651 -- Exceptional_Complete_Entry_Body ( 9652 -- _object._object, Get_GNAT_Exception); 9653 -- end; 9654 -- end entE; 9655 9656 -- Requeue of a task entry call to a task entry 9657 9658 -- Accept_Call (E, Ann); 9659 -- <start of statement sequence for accept statement> 9660 -- Requeue_Task_Entry (New._task_id, E, Abort_Present); 9661 -- goto Lnn; 9662 -- <rest of statement sequence for accept statement> 9663 -- <<Lnn>> 9664 -- Complete_Rendezvous; 9665 9666 -- exception 9667 -- when all others => 9668 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9669 9670 -- Requeue of a task entry call to a protected entry 9671 9672 -- Accept_Call (E, Ann); 9673 -- <start of statement sequence for accept statement> 9674 -- Requeue_Task_To_Protected_Entry ( 9675 -- new._object'Access, 9676 -- E, 9677 -- Abort_Present); 9678 -- newS (new, Pnn); 9679 -- goto Lnn; 9680 -- <rest of statement sequence for accept statement> 9681 -- <<Lnn>> 9682 -- Complete_Rendezvous; 9683 9684 -- exception 9685 -- when all others => 9686 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9687 9688 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9689 -- marked by pragma Implemented (XXX, By_Entry). 9690 9691 -- The requeue is inside a protected entry: 9692 9693 -- procedure entE 9694 -- (O : System.Address; 9695 -- P : System.Address; 9696 -- E : Protected_Entry_Index) 9697 -- is 9698 -- <discriminant renamings> 9699 -- <private object renamings> 9700 -- type poVP is access poV; 9701 -- _object : ptVP := ptVP!(O); 9702 9703 -- begin 9704 -- begin 9705 -- <start of statement sequence for entry> 9706 9707 -- _Disp_Requeue 9708 -- (<interface class-wide object>, 9709 -- True, 9710 -- _object'Address, 9711 -- Ada.Tags.Get_Offset_Index 9712 -- (Tag (_object), 9713 -- <interface dispatch table index of target entry>), 9714 -- Abort_Present); 9715 -- return; 9716 9717 -- <rest of statement sequence for entry> 9718 -- Complete_Entry_Body (_object._object); 9719 9720 -- exception 9721 -- when all others => 9722 -- Exceptional_Complete_Entry_Body ( 9723 -- _object._object, Get_GNAT_Exception); 9724 -- end; 9725 -- end entE; 9726 9727 -- The requeue is inside a task entry: 9728 9729 -- Accept_Call (E, Ann); 9730 -- <start of statement sequence for accept statement> 9731 -- _Disp_Requeue 9732 -- (<interface class-wide object>, 9733 -- False, 9734 -- null, 9735 -- Ada.Tags.Get_Offset_Index 9736 -- (Tag (_object), 9737 -- <interface dispatch table index of target entrt>), 9738 -- Abort_Present); 9739 -- newS (new, Pnn); 9740 -- goto Lnn; 9741 -- <rest of statement sequence for accept statement> 9742 -- <<Lnn>> 9743 -- Complete_Rendezvous; 9744 9745 -- exception 9746 -- when all others => 9747 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9748 9749 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9750 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue 9751 -- statement is replaced by a dispatching call with actual parameters taken 9752 -- from the inner-most accept statement or entry body. 9753 9754 -- Target.Primitive (Param1, ..., ParamN); 9755 9756 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9757 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked 9758 -- at all. 9759 9760 -- declare 9761 -- S : constant Offset_Index := 9762 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename)); 9763 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S); 9764 9765 -- begin 9766 -- if C = POK_Protected_Entry 9767 -- or else C = POK_Task_Entry 9768 -- then 9769 -- <statements for dispatching requeue> 9770 9771 -- elsif C = POK_Protected_Procedure then 9772 -- <dispatching call equivalent> 9773 9774 -- else 9775 -- raise Program_Error; 9776 -- end if; 9777 -- end; 9778 9779 procedure Expand_N_Requeue_Statement (N : Node_Id) is 9780 Loc : constant Source_Ptr := Sloc (N); 9781 Conc_Typ : Entity_Id; 9782 Concval : Node_Id; 9783 Ename : Node_Id; 9784 Index : Node_Id; 9785 Old_Typ : Entity_Id; 9786 9787 function Build_Dispatching_Call_Equivalent return Node_Id; 9788 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9789 -- the form Concval.Ename. It is statically known that Ename is allowed 9790 -- to be implemented by a protected procedure. Create a dispatching call 9791 -- equivalent of Concval.Ename taking the actual parameters from the 9792 -- inner-most accept statement or entry body. 9793 9794 function Build_Dispatching_Requeue return Node_Id; 9795 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9796 -- the form Concval.Ename. It is statically known that Ename is allowed 9797 -- to be implemented by a protected or a task entry. Create a call to 9798 -- primitive _Disp_Requeue which handles the low-level actions. 9799 9800 function Build_Dispatching_Requeue_To_Any return Node_Id; 9801 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9802 -- the form Concval.Ename. Ename is either marked by pragma Implemented 9803 -- (XXX, By_Any | Optional) or not marked at all. Create a block which 9804 -- determines at runtime whether Ename denotes an entry or a procedure 9805 -- and perform the appropriate kind of dispatching select. 9806 9807 function Build_Normal_Requeue return Node_Id; 9808 -- N denotes a nondispatching requeue statement to either a task or a 9809 -- protected entry. Build the appropriate runtime call to perform the 9810 -- action. 9811 9812 function Build_Skip_Statement (Search : Node_Id) return Node_Id; 9813 -- For a protected entry, create a return statement to skip the rest of 9814 -- the entry body. Otherwise, create a goto statement to skip the rest 9815 -- of a task accept statement. The lookup for the enclosing entry body 9816 -- or accept statement starts from Search. 9817 9818 --------------------------------------- 9819 -- Build_Dispatching_Call_Equivalent -- 9820 --------------------------------------- 9821 9822 function Build_Dispatching_Call_Equivalent return Node_Id is 9823 Call_Ent : constant Entity_Id := Entity (Ename); 9824 Obj : constant Node_Id := Original_Node (Concval); 9825 Acc_Ent : Node_Id; 9826 Actuals : List_Id; 9827 Formal : Node_Id; 9828 Formals : List_Id; 9829 9830 begin 9831 -- Climb the parent chain looking for the inner-most entry body or 9832 -- accept statement. 9833 9834 Acc_Ent := N; 9835 while Present (Acc_Ent) 9836 and then not Nkind_In (Acc_Ent, N_Accept_Statement, 9837 N_Entry_Body) 9838 loop 9839 Acc_Ent := Parent (Acc_Ent); 9840 end loop; 9841 9842 -- A requeue statement should be housed inside an entry body or an 9843 -- accept statement at some level. If this is not the case, then the 9844 -- tree is malformed. 9845 9846 pragma Assert (Present (Acc_Ent)); 9847 9848 -- Recover the list of formal parameters 9849 9850 if Nkind (Acc_Ent) = N_Entry_Body then 9851 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent); 9852 end if; 9853 9854 Formals := Parameter_Specifications (Acc_Ent); 9855 9856 -- Create the actual parameters for the dispatching call. These are 9857 -- simply copies of the entry body or accept statement formals in the 9858 -- same order as they appear. 9859 9860 Actuals := No_List; 9861 9862 if Present (Formals) then 9863 Actuals := New_List; 9864 Formal := First (Formals); 9865 while Present (Formal) loop 9866 Append_To (Actuals, 9867 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 9868 Next (Formal); 9869 end loop; 9870 end if; 9871 9872 -- Generate: 9873 -- Obj.Call_Ent (Actuals); 9874 9875 return 9876 Make_Procedure_Call_Statement (Loc, 9877 Name => 9878 Make_Selected_Component (Loc, 9879 Prefix => Make_Identifier (Loc, Chars (Obj)), 9880 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))), 9881 9882 Parameter_Associations => Actuals); 9883 end Build_Dispatching_Call_Equivalent; 9884 9885 ------------------------------- 9886 -- Build_Dispatching_Requeue -- 9887 ------------------------------- 9888 9889 function Build_Dispatching_Requeue return Node_Id is 9890 Params : constant List_Id := New_List; 9891 9892 begin 9893 -- Process the "with abort" parameter 9894 9895 Prepend_To (Params, 9896 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 9897 9898 -- Process the entry wrapper's position in the primary dispatch 9899 -- table parameter. Generate: 9900 9901 -- Ada.Tags.Get_Entry_Index 9902 -- (T => To_Tag_Ptr (Obj'Address).all, 9903 -- Position => 9904 -- Ada.Tags.Get_Offset_Index 9905 -- (Ada.Tags.Tag (Concval), 9906 -- <interface dispatch table position of Ename>)); 9907 9908 -- Note that Obj'Address is recursively expanded into a call to 9909 -- Base_Address (Obj). 9910 9911 if Tagged_Type_Expansion then 9912 Prepend_To (Params, 9913 Make_Function_Call (Loc, 9914 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 9915 Parameter_Associations => New_List ( 9916 9917 Make_Explicit_Dereference (Loc, 9918 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 9919 Make_Attribute_Reference (Loc, 9920 Prefix => New_Copy_Tree (Concval), 9921 Attribute_Name => Name_Address))), 9922 9923 Make_Function_Call (Loc, 9924 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 9925 Parameter_Associations => New_List ( 9926 Unchecked_Convert_To (RTE (RE_Tag), Concval), 9927 Make_Integer_Literal (Loc, 9928 DT_Position (Entity (Ename)))))))); 9929 9930 -- VM targets 9931 9932 else 9933 Prepend_To (Params, 9934 Make_Function_Call (Loc, 9935 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 9936 Parameter_Associations => New_List ( 9937 9938 Make_Attribute_Reference (Loc, 9939 Prefix => Concval, 9940 Attribute_Name => Name_Tag), 9941 9942 Make_Function_Call (Loc, 9943 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 9944 9945 Parameter_Associations => New_List ( 9946 9947 -- Obj_Tag 9948 9949 Make_Attribute_Reference (Loc, 9950 Prefix => Concval, 9951 Attribute_Name => Name_Tag), 9952 9953 -- Tag_Typ 9954 9955 Make_Attribute_Reference (Loc, 9956 Prefix => New_Occurrence_Of (Etype (Concval), Loc), 9957 Attribute_Name => Name_Tag), 9958 9959 -- Position 9960 9961 Make_Integer_Literal (Loc, 9962 DT_Position (Entity (Ename)))))))); 9963 end if; 9964 9965 -- Specific actuals for protected to XXX requeue 9966 9967 if Is_Protected_Type (Old_Typ) then 9968 Prepend_To (Params, 9969 Make_Attribute_Reference (Loc, -- _object'Address 9970 Prefix => 9971 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 9972 Attribute_Name => Name_Address)); 9973 9974 Prepend_To (Params, -- True 9975 New_Occurrence_Of (Standard_True, Loc)); 9976 9977 -- Specific actuals for task to XXX requeue 9978 9979 else 9980 pragma Assert (Is_Task_Type (Old_Typ)); 9981 9982 Prepend_To (Params, -- null 9983 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 9984 9985 Prepend_To (Params, -- False 9986 New_Occurrence_Of (Standard_False, Loc)); 9987 end if; 9988 9989 -- Add the object parameter 9990 9991 Prepend_To (Params, New_Copy_Tree (Concval)); 9992 9993 -- Generate: 9994 -- _Disp_Requeue (<Params>); 9995 9996 -- Find entity for Disp_Requeue operation, which belongs to 9997 -- the type and may not be directly visible. 9998 9999 declare 10000 Elmt : Elmt_Id; 10001 Op : Entity_Id; 10002 pragma Warnings (Off, Op); 10003 10004 begin 10005 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ))); 10006 while Present (Elmt) loop 10007 Op := Node (Elmt); 10008 exit when Chars (Op) = Name_uDisp_Requeue; 10009 Next_Elmt (Elmt); 10010 end loop; 10011 10012 return 10013 Make_Procedure_Call_Statement (Loc, 10014 Name => New_Occurrence_Of (Op, Loc), 10015 Parameter_Associations => Params); 10016 end; 10017 end Build_Dispatching_Requeue; 10018 10019 -------------------------------------- 10020 -- Build_Dispatching_Requeue_To_Any -- 10021 -------------------------------------- 10022 10023 function Build_Dispatching_Requeue_To_Any return Node_Id is 10024 Call_Ent : constant Entity_Id := Entity (Ename); 10025 Obj : constant Node_Id := Original_Node (Concval); 10026 Skip : constant Node_Id := Build_Skip_Statement (N); 10027 C : Entity_Id; 10028 Decls : List_Id; 10029 S : Entity_Id; 10030 Stmts : List_Id; 10031 10032 begin 10033 Decls := New_List; 10034 Stmts := New_List; 10035 10036 -- Dispatch table slot processing, generate: 10037 -- S : Integer; 10038 10039 S := Build_S (Loc, Decls); 10040 10041 -- Call kind processing, generate: 10042 -- C : Ada.Tags.Prim_Op_Kind; 10043 10044 C := Build_C (Loc, Decls); 10045 10046 -- Generate: 10047 -- S := Ada.Tags.Get_Offset_Index 10048 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent)); 10049 10050 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent)); 10051 10052 -- Generate: 10053 -- _Disp_Get_Prim_Op_Kind (Obj, S, C); 10054 10055 Append_To (Stmts, 10056 Make_Procedure_Call_Statement (Loc, 10057 Name => 10058 New_Occurrence_Of ( 10059 Find_Prim_Op (Etype (Etype (Obj)), 10060 Name_uDisp_Get_Prim_Op_Kind), 10061 Loc), 10062 Parameter_Associations => New_List ( 10063 New_Copy_Tree (Obj), 10064 New_Occurrence_Of (S, Loc), 10065 New_Occurrence_Of (C, Loc)))); 10066 10067 Append_To (Stmts, 10068 10069 -- if C = POK_Protected_Entry 10070 -- or else C = POK_Task_Entry 10071 -- then 10072 10073 Make_Implicit_If_Statement (N, 10074 Condition => 10075 Make_Op_Or (Loc, 10076 Left_Opnd => 10077 Make_Op_Eq (Loc, 10078 Left_Opnd => 10079 New_Occurrence_Of (C, Loc), 10080 Right_Opnd => 10081 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 10082 10083 Right_Opnd => 10084 Make_Op_Eq (Loc, 10085 Left_Opnd => 10086 New_Occurrence_Of (C, Loc), 10087 Right_Opnd => 10088 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 10089 10090 -- Dispatching requeue equivalent 10091 10092 Then_Statements => New_List ( 10093 Build_Dispatching_Requeue, 10094 Skip), 10095 10096 -- elsif C = POK_Protected_Procedure then 10097 10098 Elsif_Parts => New_List ( 10099 Make_Elsif_Part (Loc, 10100 Condition => 10101 Make_Op_Eq (Loc, 10102 Left_Opnd => 10103 New_Occurrence_Of (C, Loc), 10104 Right_Opnd => 10105 New_Occurrence_Of ( 10106 RTE (RE_POK_Protected_Procedure), Loc)), 10107 10108 -- Dispatching call equivalent 10109 10110 Then_Statements => New_List ( 10111 Build_Dispatching_Call_Equivalent))), 10112 10113 -- else 10114 -- raise Program_Error; 10115 -- end if; 10116 10117 Else_Statements => New_List ( 10118 Make_Raise_Program_Error (Loc, 10119 Reason => PE_Explicit_Raise)))); 10120 10121 -- Wrap everything into a block 10122 10123 return 10124 Make_Block_Statement (Loc, 10125 Declarations => Decls, 10126 Handled_Statement_Sequence => 10127 Make_Handled_Sequence_Of_Statements (Loc, 10128 Statements => Stmts)); 10129 end Build_Dispatching_Requeue_To_Any; 10130 10131 -------------------------- 10132 -- Build_Normal_Requeue -- 10133 -------------------------- 10134 10135 function Build_Normal_Requeue return Node_Id is 10136 Params : constant List_Id := New_List; 10137 Param : Node_Id; 10138 RT_Call : Node_Id; 10139 10140 begin 10141 -- Process the "with abort" parameter 10142 10143 Prepend_To (Params, 10144 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10145 10146 -- Add the index expression to the parameters. It is common among all 10147 -- four cases. 10148 10149 Prepend_To (Params, 10150 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ)); 10151 10152 if Is_Protected_Type (Old_Typ) then 10153 declare 10154 Self_Param : Node_Id; 10155 10156 begin 10157 Self_Param := 10158 Make_Attribute_Reference (Loc, 10159 Prefix => 10160 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10161 Attribute_Name => 10162 Name_Unchecked_Access); 10163 10164 -- Protected to protected requeue 10165 10166 if Is_Protected_Type (Conc_Typ) then 10167 RT_Call := 10168 New_Occurrence_Of ( 10169 RTE (RE_Requeue_Protected_Entry), Loc); 10170 10171 Param := 10172 Make_Attribute_Reference (Loc, 10173 Prefix => 10174 Concurrent_Ref (Concval), 10175 Attribute_Name => 10176 Name_Unchecked_Access); 10177 10178 -- Protected to task requeue 10179 10180 else pragma Assert (Is_Task_Type (Conc_Typ)); 10181 RT_Call := 10182 New_Occurrence_Of ( 10183 RTE (RE_Requeue_Protected_To_Task_Entry), Loc); 10184 10185 Param := Concurrent_Ref (Concval); 10186 end if; 10187 10188 Prepend_To (Params, Param); 10189 Prepend_To (Params, Self_Param); 10190 end; 10191 10192 else pragma Assert (Is_Task_Type (Old_Typ)); 10193 10194 -- Task to protected requeue 10195 10196 if Is_Protected_Type (Conc_Typ) then 10197 RT_Call := 10198 New_Occurrence_Of ( 10199 RTE (RE_Requeue_Task_To_Protected_Entry), Loc); 10200 10201 Param := 10202 Make_Attribute_Reference (Loc, 10203 Prefix => 10204 Concurrent_Ref (Concval), 10205 Attribute_Name => 10206 Name_Unchecked_Access); 10207 10208 -- Task to task requeue 10209 10210 else pragma Assert (Is_Task_Type (Conc_Typ)); 10211 RT_Call := 10212 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc); 10213 10214 Param := Concurrent_Ref (Concval); 10215 end if; 10216 10217 Prepend_To (Params, Param); 10218 end if; 10219 10220 return 10221 Make_Procedure_Call_Statement (Loc, 10222 Name => RT_Call, 10223 Parameter_Associations => Params); 10224 end Build_Normal_Requeue; 10225 10226 -------------------------- 10227 -- Build_Skip_Statement -- 10228 -------------------------- 10229 10230 function Build_Skip_Statement (Search : Node_Id) return Node_Id is 10231 Skip_Stmt : Node_Id; 10232 10233 begin 10234 -- Build a return statement to skip the rest of the entire body 10235 10236 if Is_Protected_Type (Old_Typ) then 10237 Skip_Stmt := Make_Simple_Return_Statement (Loc); 10238 10239 -- If the requeue is within a task, find the end label of the 10240 -- enclosing accept statement and create a goto statement to it. 10241 10242 else 10243 declare 10244 Acc : Node_Id; 10245 Label : Node_Id; 10246 10247 begin 10248 -- Climb the parent chain looking for the enclosing accept 10249 -- statement. 10250 10251 Acc := Parent (Search); 10252 while Present (Acc) 10253 and then Nkind (Acc) /= N_Accept_Statement 10254 loop 10255 Acc := Parent (Acc); 10256 end loop; 10257 10258 -- The last statement is the second label used for completing 10259 -- the rendezvous the usual way. The label we are looking for 10260 -- is right before it. 10261 10262 Label := 10263 Prev (Last (Statements (Handled_Statement_Sequence (Acc)))); 10264 10265 pragma Assert (Nkind (Label) = N_Label); 10266 10267 -- Generate a goto statement to skip the rest of the accept 10268 10269 Skip_Stmt := 10270 Make_Goto_Statement (Loc, 10271 Name => 10272 New_Occurrence_Of (Entity (Identifier (Label)), Loc)); 10273 end; 10274 end if; 10275 10276 Set_Analyzed (Skip_Stmt); 10277 10278 return Skip_Stmt; 10279 end Build_Skip_Statement; 10280 10281 -- Start of processing for Expand_N_Requeue_Statement 10282 10283 begin 10284 -- Extract the components of the entry call 10285 10286 Extract_Entry (N, Concval, Ename, Index); 10287 Conc_Typ := Etype (Concval); 10288 10289 -- If the prefix is an access to class-wide type, dereference to get 10290 -- object and entry type. 10291 10292 if Is_Access_Type (Conc_Typ) then 10293 Conc_Typ := Designated_Type (Conc_Typ); 10294 Rewrite (Concval, 10295 Make_Explicit_Dereference (Loc, Relocate_Node (Concval))); 10296 Analyze_And_Resolve (Concval, Conc_Typ); 10297 end if; 10298 10299 -- Examine the scope stack in order to find nearest enclosing protected 10300 -- or task type. This will constitute our invocation source. 10301 10302 Old_Typ := Current_Scope; 10303 while Present (Old_Typ) 10304 and then not Is_Protected_Type (Old_Typ) 10305 and then not Is_Task_Type (Old_Typ) 10306 loop 10307 Old_Typ := Scope (Old_Typ); 10308 end loop; 10309 10310 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form 10311 -- Concval.Ename where the type of Concval is class-wide concurrent 10312 -- interface. 10313 10314 if Ada_Version >= Ada_2012 10315 and then Present (Concval) 10316 and then Is_Class_Wide_Type (Conc_Typ) 10317 and then Is_Concurrent_Interface (Conc_Typ) 10318 then 10319 declare 10320 Has_Impl : Boolean := False; 10321 Impl_Kind : Name_Id := No_Name; 10322 10323 begin 10324 -- Check whether the Ename is flagged by pragma Implemented 10325 10326 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then 10327 Has_Impl := True; 10328 Impl_Kind := Implementation_Kind (Entity (Ename)); 10329 end if; 10330 10331 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10332 -- an entry. Create a call to predefined primitive _Disp_Requeue. 10333 10334 if Has_Impl and then Impl_Kind = Name_By_Entry then 10335 Rewrite (N, Build_Dispatching_Requeue); 10336 Analyze (N); 10337 Insert_After (N, Build_Skip_Statement (N)); 10338 10339 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10340 -- a protected procedure. In this case the requeue is transformed 10341 -- into a dispatching call. 10342 10343 elsif Has_Impl 10344 and then Impl_Kind = Name_By_Protected_Procedure 10345 then 10346 Rewrite (N, Build_Dispatching_Call_Equivalent); 10347 Analyze (N); 10348 10349 -- The procedure_or_entry_NAME's implementation kind is either 10350 -- By_Any, Optional, or pragma Implemented was not applied at all. 10351 -- In this case a runtime test determines whether Ename denotes an 10352 -- entry or a protected procedure and performs the appropriate 10353 -- call. 10354 10355 else 10356 Rewrite (N, Build_Dispatching_Requeue_To_Any); 10357 Analyze (N); 10358 end if; 10359 end; 10360 10361 -- Processing for regular (nondispatching) requeues 10362 10363 else 10364 Rewrite (N, Build_Normal_Requeue); 10365 Analyze (N); 10366 Insert_After (N, Build_Skip_Statement (N)); 10367 end if; 10368 end Expand_N_Requeue_Statement; 10369 10370 ------------------------------- 10371 -- Expand_N_Selective_Accept -- 10372 ------------------------------- 10373 10374 procedure Expand_N_Selective_Accept (N : Node_Id) is 10375 Loc : constant Source_Ptr := Sloc (N); 10376 Alts : constant List_Id := Select_Alternatives (N); 10377 10378 -- Note: in the below declarations a lot of new lists are allocated 10379 -- unconditionally which may well not end up being used. That's not 10380 -- a good idea since it wastes space gratuitously ??? 10381 10382 Accept_Case : List_Id; 10383 Accept_List : constant List_Id := New_List; 10384 10385 Alt : Node_Id; 10386 Alt_List : constant List_Id := New_List; 10387 Alt_Stats : List_Id; 10388 Ann : Entity_Id := Empty; 10389 10390 Check_Guard : Boolean := True; 10391 10392 Decls : constant List_Id := New_List; 10393 Stats : constant List_Id := New_List; 10394 Body_List : constant List_Id := New_List; 10395 Trailing_List : constant List_Id := New_List; 10396 10397 Choices : List_Id; 10398 Else_Present : Boolean := False; 10399 Terminate_Alt : Node_Id := Empty; 10400 Select_Mode : Node_Id; 10401 10402 Delay_Case : List_Id; 10403 Delay_Count : Integer := 0; 10404 Delay_Val : Entity_Id; 10405 Delay_Index : Entity_Id; 10406 Delay_Min : Entity_Id; 10407 Delay_Num : Pos := 1; 10408 Delay_Alt_List : List_Id := New_List; 10409 Delay_List : constant List_Id := New_List; 10410 D : Entity_Id; 10411 M : Entity_Id; 10412 10413 First_Delay : Boolean := True; 10414 Guard_Open : Entity_Id; 10415 10416 End_Lab : Node_Id; 10417 Index : Pos := 1; 10418 Lab : Node_Id; 10419 Num_Alts : Nat; 10420 Num_Accept : Nat := 0; 10421 Proc : Node_Id; 10422 Time_Type : Entity_Id; 10423 Select_Call : Node_Id; 10424 10425 Qnam : constant Entity_Id := 10426 Make_Defining_Identifier (Loc, New_External_Name ('S', 0)); 10427 10428 Xnam : constant Entity_Id := 10429 Make_Defining_Identifier (Loc, New_External_Name ('J', 1)); 10430 10431 ----------------------- 10432 -- Local subprograms -- 10433 ----------------------- 10434 10435 function Accept_Or_Raise return List_Id; 10436 -- For the rare case where delay alternatives all have guards, and 10437 -- all of them are closed, it is still possible that there were open 10438 -- accept alternatives with no callers. We must reexamine the 10439 -- Accept_List, and execute a selective wait with no else if some 10440 -- accept is open. If none, we raise program_error. 10441 10442 procedure Add_Accept (Alt : Node_Id); 10443 -- Process a single accept statement in a select alternative. Build 10444 -- procedure for body of accept, and add entry to dispatch table with 10445 -- expression for guard, in preparation for call to run time select. 10446 10447 function Make_And_Declare_Label (Num : Int) return Node_Id; 10448 -- Manufacture a label using Num as a serial number and declare it. 10449 -- The declaration is appended to Decls. The label marks the trailing 10450 -- statements of an accept or delay alternative. 10451 10452 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; 10453 -- Build call to Selective_Wait runtime routine 10454 10455 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); 10456 -- Add code to compare value of delay with previous values, and 10457 -- generate case entry for trailing statements. 10458 10459 procedure Process_Accept_Alternative 10460 (Alt : Node_Id; 10461 Index : Int; 10462 Proc : Node_Id); 10463 -- Add code to call corresponding procedure, and branch to 10464 -- trailing statements, if any. 10465 10466 --------------------- 10467 -- Accept_Or_Raise -- 10468 --------------------- 10469 10470 function Accept_Or_Raise return List_Id is 10471 Cond : Node_Id; 10472 Stats : List_Id; 10473 J : constant Entity_Id := Make_Temporary (Loc, 'J'); 10474 10475 begin 10476 -- We generate the following: 10477 10478 -- for J in q'range loop 10479 -- if q(J).S /=null_task_entry then 10480 -- selective_wait (simple_mode,...); 10481 -- done := True; 10482 -- exit; 10483 -- end if; 10484 -- end loop; 10485 -- 10486 -- if no rendez_vous then 10487 -- raise program_error; 10488 -- end if; 10489 10490 -- Note that the code needs to know that the selector name 10491 -- in an Accept_Alternative is named S. 10492 10493 Cond := Make_Op_Ne (Loc, 10494 Left_Opnd => 10495 Make_Selected_Component (Loc, 10496 Prefix => 10497 Make_Indexed_Component (Loc, 10498 Prefix => New_Occurrence_Of (Qnam, Loc), 10499 Expressions => New_List (New_Occurrence_Of (J, Loc))), 10500 Selector_Name => Make_Identifier (Loc, Name_S)), 10501 Right_Opnd => 10502 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc)); 10503 10504 Stats := New_List ( 10505 Make_Implicit_Loop_Statement (N, 10506 Iteration_Scheme => 10507 Make_Iteration_Scheme (Loc, 10508 Loop_Parameter_Specification => 10509 Make_Loop_Parameter_Specification (Loc, 10510 Defining_Identifier => J, 10511 Discrete_Subtype_Definition => 10512 Make_Attribute_Reference (Loc, 10513 Prefix => New_Occurrence_Of (Qnam, Loc), 10514 Attribute_Name => Name_Range, 10515 Expressions => New_List ( 10516 Make_Integer_Literal (Loc, 1))))), 10517 10518 Statements => New_List ( 10519 Make_Implicit_If_Statement (N, 10520 Condition => Cond, 10521 Then_Statements => New_List ( 10522 Make_Select_Call ( 10523 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)), 10524 Make_Exit_Statement (Loc)))))); 10525 10526 Append_To (Stats, 10527 Make_Raise_Program_Error (Loc, 10528 Condition => Make_Op_Eq (Loc, 10529 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 10530 Right_Opnd => 10531 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 10532 Reason => PE_All_Guards_Closed)); 10533 10534 return Stats; 10535 end Accept_Or_Raise; 10536 10537 ---------------- 10538 -- Add_Accept -- 10539 ---------------- 10540 10541 procedure Add_Accept (Alt : Node_Id) is 10542 Acc_Stm : constant Node_Id := Accept_Statement (Alt); 10543 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm); 10544 Eloc : constant Source_Ptr := Sloc (Ename); 10545 Eent : constant Entity_Id := Entity (Ename); 10546 Index : constant Node_Id := Entry_Index (Acc_Stm); 10547 Null_Body : Node_Id; 10548 Proc_Body : Node_Id; 10549 PB_Ent : Entity_Id; 10550 Expr : Node_Id; 10551 Call : Node_Id; 10552 10553 begin 10554 if No (Ann) then 10555 Ann := Node (Last_Elmt (Accept_Address (Eent))); 10556 end if; 10557 10558 if Present (Condition (Alt)) then 10559 Expr := 10560 Make_If_Expression (Eloc, New_List ( 10561 Condition (Alt), 10562 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)), 10563 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc))); 10564 else 10565 Expr := 10566 Entry_Index_Expression 10567 (Eloc, Eent, Index, Scope (Eent)); 10568 end if; 10569 10570 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then 10571 Null_Body := New_Occurrence_Of (Standard_False, Eloc); 10572 10573 -- Always add call to Abort_Undefer when generating code, since 10574 -- this is what the runtime expects (abort deferred in 10575 -- Selective_Wait). In CodePeer mode this only confuses the 10576 -- analysis with unknown calls, so don't do it. 10577 10578 if not CodePeer_Mode then 10579 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 10580 Insert_Before 10581 (First (Statements (Handled_Statement_Sequence 10582 (Accept_Statement (Alt)))), 10583 Call); 10584 Analyze (Call); 10585 end if; 10586 10587 PB_Ent := 10588 Make_Defining_Identifier (Eloc, 10589 New_External_Name (Chars (Ename), 'A', Num_Accept)); 10590 10591 -- Link the acceptor to the original receiving entry 10592 10593 Set_Ekind (PB_Ent, E_Procedure); 10594 Set_Receiving_Entry (PB_Ent, Eent); 10595 10596 if Comes_From_Source (Alt) then 10597 Set_Debug_Info_Needed (PB_Ent); 10598 end if; 10599 10600 Proc_Body := 10601 Make_Subprogram_Body (Eloc, 10602 Specification => 10603 Make_Procedure_Specification (Eloc, 10604 Defining_Unit_Name => PB_Ent), 10605 Declarations => Declarations (Acc_Stm), 10606 Handled_Statement_Sequence => 10607 Build_Accept_Body (Accept_Statement (Alt))); 10608 10609 -- During the analysis of the body of the accept statement, any 10610 -- zero cost exception handler records were collected in the 10611 -- Accept_Handler_Records field of the N_Accept_Alternative node. 10612 -- This is where we move them to where they belong, namely the 10613 -- newly created procedure. 10614 10615 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); 10616 Append (Proc_Body, Body_List); 10617 10618 else 10619 Null_Body := New_Occurrence_Of (Standard_True, Eloc); 10620 10621 -- if accept statement has declarations, insert above, given that 10622 -- we are not creating a body for the accept. 10623 10624 if Present (Declarations (Acc_Stm)) then 10625 Insert_Actions (N, Declarations (Acc_Stm)); 10626 end if; 10627 end if; 10628 10629 Append_To (Accept_List, 10630 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr))); 10631 10632 Num_Accept := Num_Accept + 1; 10633 end Add_Accept; 10634 10635 ---------------------------- 10636 -- Make_And_Declare_Label -- 10637 ---------------------------- 10638 10639 function Make_And_Declare_Label (Num : Int) return Node_Id is 10640 Lab_Id : Node_Id; 10641 10642 begin 10643 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num)); 10644 Lab := 10645 Make_Label (Loc, Lab_Id); 10646 10647 Append_To (Decls, 10648 Make_Implicit_Label_Declaration (Loc, 10649 Defining_Identifier => 10650 Make_Defining_Identifier (Loc, Chars (Lab_Id)), 10651 Label_Construct => Lab)); 10652 10653 return Lab; 10654 end Make_And_Declare_Label; 10655 10656 ---------------------- 10657 -- Make_Select_Call -- 10658 ---------------------- 10659 10660 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is 10661 Params : constant List_Id := New_List; 10662 10663 begin 10664 Append_To (Params, 10665 Make_Attribute_Reference (Loc, 10666 Prefix => New_Occurrence_Of (Qnam, Loc), 10667 Attribute_Name => Name_Unchecked_Access)); 10668 Append_To (Params, Select_Mode); 10669 Append_To (Params, New_Occurrence_Of (Ann, Loc)); 10670 Append_To (Params, New_Occurrence_Of (Xnam, Loc)); 10671 10672 return 10673 Make_Procedure_Call_Statement (Loc, 10674 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc), 10675 Parameter_Associations => Params); 10676 end Make_Select_Call; 10677 10678 -------------------------------- 10679 -- Process_Accept_Alternative -- 10680 -------------------------------- 10681 10682 procedure Process_Accept_Alternative 10683 (Alt : Node_Id; 10684 Index : Int; 10685 Proc : Node_Id) 10686 is 10687 Astmt : constant Node_Id := Accept_Statement (Alt); 10688 Alt_Stats : List_Id; 10689 10690 begin 10691 Adjust_Condition (Condition (Alt)); 10692 10693 -- Accept with body 10694 10695 if Present (Handled_Statement_Sequence (Astmt)) then 10696 Alt_Stats := 10697 New_List ( 10698 Make_Procedure_Call_Statement (Sloc (Proc), 10699 Name => 10700 New_Occurrence_Of 10701 (Defining_Unit_Name (Specification (Proc)), 10702 Sloc (Proc)))); 10703 10704 -- Accept with no body (followed by trailing statements) 10705 10706 else 10707 Alt_Stats := Empty_List; 10708 end if; 10709 10710 Ensure_Statement_Present (Sloc (Astmt), Alt); 10711 10712 -- After the call, if any, branch to trailing statements, if any. 10713 -- We create a label for each, as well as the corresponding label 10714 -- declaration. 10715 10716 if not Is_Empty_List (Statements (Alt)) then 10717 Lab := Make_And_Declare_Label (Index); 10718 Append (Lab, Trailing_List); 10719 Append_List (Statements (Alt), Trailing_List); 10720 Append_To (Trailing_List, 10721 Make_Goto_Statement (Loc, 10722 Name => New_Copy (Identifier (End_Lab)))); 10723 10724 else 10725 Lab := End_Lab; 10726 end if; 10727 10728 Append_To (Alt_Stats, 10729 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab)))); 10730 10731 Append_To (Alt_List, 10732 Make_Case_Statement_Alternative (Loc, 10733 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)), 10734 Statements => Alt_Stats)); 10735 end Process_Accept_Alternative; 10736 10737 ------------------------------- 10738 -- Process_Delay_Alternative -- 10739 ------------------------------- 10740 10741 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is 10742 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt)); 10743 Cond : Node_Id; 10744 Delay_Alt : List_Id; 10745 10746 begin 10747 -- Deal with C/Fortran boolean as delay condition 10748 10749 Adjust_Condition (Condition (Alt)); 10750 10751 -- Determine the smallest specified delay 10752 10753 -- for each delay alternative generate: 10754 10755 -- if guard-expression then 10756 -- Delay_Val := delay-expression; 10757 -- Guard_Open := True; 10758 -- if Delay_Val < Delay_Min then 10759 -- Delay_Min := Delay_Val; 10760 -- Delay_Index := Index; 10761 -- end if; 10762 -- end if; 10763 10764 -- The enclosing if-statement is omitted if there is no guard 10765 10766 if Delay_Count = 1 or else First_Delay then 10767 First_Delay := False; 10768 10769 Delay_Alt := New_List ( 10770 Make_Assignment_Statement (Loc, 10771 Name => New_Occurrence_Of (Delay_Min, Loc), 10772 Expression => Expression (Delay_Statement (Alt)))); 10773 10774 if Delay_Count > 1 then 10775 Append_To (Delay_Alt, 10776 Make_Assignment_Statement (Loc, 10777 Name => New_Occurrence_Of (Delay_Index, Loc), 10778 Expression => Make_Integer_Literal (Loc, Index))); 10779 end if; 10780 10781 else 10782 Delay_Alt := New_List ( 10783 Make_Assignment_Statement (Loc, 10784 Name => New_Occurrence_Of (Delay_Val, Loc), 10785 Expression => Expression (Delay_Statement (Alt)))); 10786 10787 if Time_Type = Standard_Duration then 10788 Cond := 10789 Make_Op_Lt (Loc, 10790 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc), 10791 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc)); 10792 10793 else 10794 -- The scope of the time type must define a comparison 10795 -- operator. The scope itself may not be visible, so we 10796 -- construct a node with entity information to insure that 10797 -- semantic analysis can find the proper operator. 10798 10799 Cond := 10800 Make_Function_Call (Loc, 10801 Name => Make_Selected_Component (Loc, 10802 Prefix => 10803 New_Occurrence_Of (Scope (Time_Type), Loc), 10804 Selector_Name => 10805 Make_Operator_Symbol (Loc, 10806 Chars => Name_Op_Lt, 10807 Strval => No_String)), 10808 Parameter_Associations => 10809 New_List ( 10810 New_Occurrence_Of (Delay_Val, Loc), 10811 New_Occurrence_Of (Delay_Min, Loc))); 10812 10813 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type)); 10814 end if; 10815 10816 Append_To (Delay_Alt, 10817 Make_Implicit_If_Statement (N, 10818 Condition => Cond, 10819 Then_Statements => New_List ( 10820 Make_Assignment_Statement (Loc, 10821 Name => New_Occurrence_Of (Delay_Min, Loc), 10822 Expression => New_Occurrence_Of (Delay_Val, Loc)), 10823 10824 Make_Assignment_Statement (Loc, 10825 Name => New_Occurrence_Of (Delay_Index, Loc), 10826 Expression => Make_Integer_Literal (Loc, Index))))); 10827 end if; 10828 10829 if Check_Guard then 10830 Append_To (Delay_Alt, 10831 Make_Assignment_Statement (Loc, 10832 Name => New_Occurrence_Of (Guard_Open, Loc), 10833 Expression => New_Occurrence_Of (Standard_True, Loc))); 10834 end if; 10835 10836 if Present (Condition (Alt)) then 10837 Delay_Alt := New_List ( 10838 Make_Implicit_If_Statement (N, 10839 Condition => Condition (Alt), 10840 Then_Statements => Delay_Alt)); 10841 end if; 10842 10843 Append_List (Delay_Alt, Delay_List); 10844 10845 Ensure_Statement_Present (Dloc, Alt); 10846 10847 -- If the delay alternative has a statement part, add choice to the 10848 -- case statements for delays. 10849 10850 if not Is_Empty_List (Statements (Alt)) then 10851 10852 if Delay_Count = 1 then 10853 Append_List (Statements (Alt), Delay_Alt_List); 10854 10855 else 10856 Append_To (Delay_Alt_List, 10857 Make_Case_Statement_Alternative (Loc, 10858 Discrete_Choices => New_List ( 10859 Make_Integer_Literal (Loc, Index)), 10860 Statements => Statements (Alt))); 10861 end if; 10862 10863 elsif Delay_Count = 1 then 10864 10865 -- If the single delay has no trailing statements, add a branch 10866 -- to the exit label to the selective wait. 10867 10868 Delay_Alt_List := New_List ( 10869 Make_Goto_Statement (Loc, 10870 Name => New_Copy (Identifier (End_Lab)))); 10871 10872 end if; 10873 end Process_Delay_Alternative; 10874 10875 -- Start of processing for Expand_N_Selective_Accept 10876 10877 begin 10878 Process_Statements_For_Controlled_Objects (N); 10879 10880 -- First insert some declarations before the select. The first is: 10881 10882 -- Ann : Address 10883 10884 -- This variable holds the parameters passed to the accept body. This 10885 -- declaration has already been inserted by the time we get here by 10886 -- a call to Expand_Accept_Declarations made from the semantics when 10887 -- processing the first accept statement contained in the select. We 10888 -- can find this entity as Accept_Address (E), where E is any of the 10889 -- entries references by contained accept statements. 10890 10891 -- The first step is to scan the list of Selective_Accept_Statements 10892 -- to find this entity, and also count the number of accepts, and 10893 -- determine if terminated, delay or else is present: 10894 10895 Num_Alts := 0; 10896 10897 Alt := First (Alts); 10898 while Present (Alt) loop 10899 Process_Statements_For_Controlled_Objects (Alt); 10900 10901 if Nkind (Alt) = N_Accept_Alternative then 10902 Add_Accept (Alt); 10903 10904 elsif Nkind (Alt) = N_Delay_Alternative then 10905 Delay_Count := Delay_Count + 1; 10906 10907 -- If the delays are relative delays, the delay expressions have 10908 -- type Standard_Duration. Otherwise they must have some time type 10909 -- recognized by GNAT. 10910 10911 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then 10912 Time_Type := Standard_Duration; 10913 else 10914 Time_Type := Etype (Expression (Delay_Statement (Alt))); 10915 10916 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) 10917 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time) 10918 then 10919 null; 10920 else 10921 Error_Msg_NE ( 10922 "& is not a time type (RM 9.6(6))", 10923 Expression (Delay_Statement (Alt)), Time_Type); 10924 Time_Type := Standard_Duration; 10925 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type); 10926 end if; 10927 end if; 10928 10929 if No (Condition (Alt)) then 10930 10931 -- This guard will always be open 10932 10933 Check_Guard := False; 10934 end if; 10935 10936 elsif Nkind (Alt) = N_Terminate_Alternative then 10937 Adjust_Condition (Condition (Alt)); 10938 Terminate_Alt := Alt; 10939 end if; 10940 10941 Num_Alts := Num_Alts + 1; 10942 Next (Alt); 10943 end loop; 10944 10945 Else_Present := Present (Else_Statements (N)); 10946 10947 -- At the same time (see procedure Add_Accept) we build the accept list: 10948 10949 -- Qnn : Accept_List (1 .. num-select) := ( 10950 -- (null-body, entry-index), 10951 -- (null-body, entry-index), 10952 -- .. 10953 -- (null_body, entry-index)); 10954 10955 -- In the above declaration, null-body is True if the corresponding 10956 -- accept has no body, and false otherwise. The entry is either the 10957 -- entry index expression if there is no guard, or if a guard is 10958 -- present, then an if expression of the form: 10959 10960 -- (if guard then entry-index else Null_Task_Entry) 10961 10962 -- If a guard is statically known to be false, the entry can simply 10963 -- be omitted from the accept list. 10964 10965 Append_To (Decls, 10966 Make_Object_Declaration (Loc, 10967 Defining_Identifier => Qnam, 10968 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc), 10969 Aliased_Present => True, 10970 Expression => 10971 Make_Qualified_Expression (Loc, 10972 Subtype_Mark => 10973 New_Occurrence_Of (RTE (RE_Accept_List), Loc), 10974 Expression => 10975 Make_Aggregate (Loc, Expressions => Accept_List)))); 10976 10977 -- Then we declare the variable that holds the index for the accept 10978 -- that will be selected for service: 10979 10980 -- Xnn : Select_Index; 10981 10982 Append_To (Decls, 10983 Make_Object_Declaration (Loc, 10984 Defining_Identifier => Xnam, 10985 Object_Definition => 10986 New_Occurrence_Of (RTE (RE_Select_Index), Loc), 10987 Expression => 10988 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc))); 10989 10990 -- After this follow procedure declarations for each accept body 10991 10992 -- procedure Pnn is 10993 -- begin 10994 -- ... 10995 -- end; 10996 10997 -- where the ... are statements from the corresponding procedure body. 10998 -- No parameters are involved, since the parameters are passed via Ann 10999 -- and the parameter references have already been expanded to be direct 11000 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, 11001 -- any embedded tasking statements (which would normally be illegal in 11002 -- procedures), have been converted to calls to the tasking runtime so 11003 -- there is no problem in putting them into procedures. 11004 11005 -- The original accept statement has been expanded into a block in 11006 -- the same fashion as for simple accepts (see Build_Accept_Body). 11007 11008 -- Note: we don't really need to build these procedures for the case 11009 -- where no delay statement is present, but it is just as easy to 11010 -- build them unconditionally, and not significantly inefficient, 11011 -- since if they are short they will be inlined anyway. 11012 11013 -- The procedure declarations have been assembled in Body_List 11014 11015 -- If delays are present, we must compute the required delay. 11016 -- We first generate the declarations: 11017 11018 -- Delay_Index : Boolean := 0; 11019 -- Delay_Min : Some_Time_Type.Time; 11020 -- Delay_Val : Some_Time_Type.Time; 11021 11022 -- Delay_Index will be set to the index of the minimum delay, i.e. the 11023 -- active delay that is actually chosen as the basis for the possible 11024 -- delay if an immediate rendez-vous is not possible. 11025 11026 -- In the most common case there is a single delay statement, and this 11027 -- is handled specially. 11028 11029 if Delay_Count > 0 then 11030 11031 -- Generate the required declarations 11032 11033 Delay_Val := 11034 Make_Defining_Identifier (Loc, New_External_Name ('D', 1)); 11035 Delay_Index := 11036 Make_Defining_Identifier (Loc, New_External_Name ('D', 2)); 11037 Delay_Min := 11038 Make_Defining_Identifier (Loc, New_External_Name ('D', 3)); 11039 11040 Append_To (Decls, 11041 Make_Object_Declaration (Loc, 11042 Defining_Identifier => Delay_Val, 11043 Object_Definition => New_Occurrence_Of (Time_Type, Loc))); 11044 11045 Append_To (Decls, 11046 Make_Object_Declaration (Loc, 11047 Defining_Identifier => Delay_Index, 11048 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 11049 Expression => Make_Integer_Literal (Loc, 0))); 11050 11051 Append_To (Decls, 11052 Make_Object_Declaration (Loc, 11053 Defining_Identifier => Delay_Min, 11054 Object_Definition => New_Occurrence_Of (Time_Type, Loc), 11055 Expression => 11056 Unchecked_Convert_To (Time_Type, 11057 Make_Attribute_Reference (Loc, 11058 Prefix => 11059 New_Occurrence_Of (Underlying_Type (Time_Type), Loc), 11060 Attribute_Name => Name_Last)))); 11061 11062 -- Create Duration and Delay_Mode objects used for passing a delay 11063 -- value to RTS 11064 11065 D := Make_Temporary (Loc, 'D'); 11066 M := Make_Temporary (Loc, 'M'); 11067 11068 declare 11069 Discr : Entity_Id; 11070 11071 begin 11072 -- Note that these values are defined in s-osprim.ads and must 11073 -- be kept in sync: 11074 -- 11075 -- Relative : constant := 0; 11076 -- Absolute_Calendar : constant := 1; 11077 -- Absolute_RT : constant := 2; 11078 11079 if Time_Type = Standard_Duration then 11080 Discr := Make_Integer_Literal (Loc, 0); 11081 11082 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11083 Discr := Make_Integer_Literal (Loc, 1); 11084 11085 else 11086 pragma Assert 11087 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11088 Discr := Make_Integer_Literal (Loc, 2); 11089 end if; 11090 11091 Append_To (Decls, 11092 Make_Object_Declaration (Loc, 11093 Defining_Identifier => D, 11094 Object_Definition => 11095 New_Occurrence_Of (Standard_Duration, Loc))); 11096 11097 Append_To (Decls, 11098 Make_Object_Declaration (Loc, 11099 Defining_Identifier => M, 11100 Object_Definition => 11101 New_Occurrence_Of (Standard_Integer, Loc), 11102 Expression => Discr)); 11103 end; 11104 11105 if Check_Guard then 11106 Guard_Open := 11107 Make_Defining_Identifier (Loc, New_External_Name ('G', 1)); 11108 11109 Append_To (Decls, 11110 Make_Object_Declaration (Loc, 11111 Defining_Identifier => Guard_Open, 11112 Object_Definition => 11113 New_Occurrence_Of (Standard_Boolean, Loc), 11114 Expression => 11115 New_Occurrence_Of (Standard_False, Loc))); 11116 end if; 11117 11118 -- Delay_Count is zero, don't need M and D set (suppress warning) 11119 11120 else 11121 M := Empty; 11122 D := Empty; 11123 end if; 11124 11125 if Present (Terminate_Alt) then 11126 11127 -- If the terminate alternative guard is False, use 11128 -- Simple_Mode; otherwise use Terminate_Mode. 11129 11130 if Present (Condition (Terminate_Alt)) then 11131 Select_Mode := Make_If_Expression (Loc, 11132 New_List (Condition (Terminate_Alt), 11133 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc), 11134 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc))); 11135 else 11136 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc); 11137 end if; 11138 11139 elsif Else_Present or Delay_Count > 0 then 11140 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc); 11141 11142 else 11143 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc); 11144 end if; 11145 11146 Select_Call := Make_Select_Call (Select_Mode); 11147 Append (Select_Call, Stats); 11148 11149 -- Now generate code to act on the result. There is an entry 11150 -- in this case for each accept statement with a non-null body, 11151 -- followed by a branch to the statements that follow the Accept. 11152 -- In the absence of delay alternatives, we generate: 11153 11154 -- case X is 11155 -- when No_Rendezvous => -- omitted if simple mode 11156 -- goto Lab0; 11157 11158 -- when 1 => 11159 -- P1n; 11160 -- goto Lab1; 11161 11162 -- when 2 => 11163 -- P2n; 11164 -- goto Lab2; 11165 11166 -- when others => 11167 -- goto Exit; 11168 -- end case; 11169 -- 11170 -- Lab0: Else_Statements; 11171 -- goto exit; 11172 11173 -- Lab1: Trailing_Statements1; 11174 -- goto Exit; 11175 -- 11176 -- Lab2: Trailing_Statements2; 11177 -- goto Exit; 11178 -- ... 11179 -- Exit: 11180 11181 -- Generate label for common exit 11182 11183 End_Lab := Make_And_Declare_Label (Num_Alts + 1); 11184 11185 -- First entry is the default case, when no rendezvous is possible 11186 11187 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)); 11188 11189 if Else_Present then 11190 11191 -- If no rendezvous is possible, the else part is executed 11192 11193 Lab := Make_And_Declare_Label (0); 11194 Alt_Stats := New_List ( 11195 Make_Goto_Statement (Loc, 11196 Name => New_Copy (Identifier (Lab)))); 11197 11198 Append (Lab, Trailing_List); 11199 Append_List (Else_Statements (N), Trailing_List); 11200 Append_To (Trailing_List, 11201 Make_Goto_Statement (Loc, 11202 Name => New_Copy (Identifier (End_Lab)))); 11203 else 11204 Alt_Stats := New_List ( 11205 Make_Goto_Statement (Loc, 11206 Name => New_Copy (Identifier (End_Lab)))); 11207 end if; 11208 11209 Append_To (Alt_List, 11210 Make_Case_Statement_Alternative (Loc, 11211 Discrete_Choices => Choices, 11212 Statements => Alt_Stats)); 11213 11214 -- We make use of the fact that Accept_Index is an integer type, and 11215 -- generate successive literals for entries for each accept. Only those 11216 -- for which there is a body or trailing statements get a case entry. 11217 11218 Alt := First (Select_Alternatives (N)); 11219 Proc := First (Body_List); 11220 while Present (Alt) loop 11221 11222 if Nkind (Alt) = N_Accept_Alternative then 11223 Process_Accept_Alternative (Alt, Index, Proc); 11224 Index := Index + 1; 11225 11226 if Present 11227 (Handled_Statement_Sequence (Accept_Statement (Alt))) 11228 then 11229 Next (Proc); 11230 end if; 11231 11232 elsif Nkind (Alt) = N_Delay_Alternative then 11233 Process_Delay_Alternative (Alt, Delay_Num); 11234 Delay_Num := Delay_Num + 1; 11235 end if; 11236 11237 Next (Alt); 11238 end loop; 11239 11240 -- An others choice is always added to the main case, as well 11241 -- as the delay case (to satisfy the compiler). 11242 11243 Append_To (Alt_List, 11244 Make_Case_Statement_Alternative (Loc, 11245 Discrete_Choices => 11246 New_List (Make_Others_Choice (Loc)), 11247 Statements => 11248 New_List (Make_Goto_Statement (Loc, 11249 Name => New_Copy (Identifier (End_Lab)))))); 11250 11251 Accept_Case := New_List ( 11252 Make_Case_Statement (Loc, 11253 Expression => New_Occurrence_Of (Xnam, Loc), 11254 Alternatives => Alt_List)); 11255 11256 Append_List (Trailing_List, Accept_Case); 11257 Append_List (Body_List, Decls); 11258 11259 -- Construct case statement for trailing statements of delay 11260 -- alternatives, if there are several of them. 11261 11262 if Delay_Count > 1 then 11263 Append_To (Delay_Alt_List, 11264 Make_Case_Statement_Alternative (Loc, 11265 Discrete_Choices => 11266 New_List (Make_Others_Choice (Loc)), 11267 Statements => 11268 New_List (Make_Null_Statement (Loc)))); 11269 11270 Delay_Case := New_List ( 11271 Make_Case_Statement (Loc, 11272 Expression => New_Occurrence_Of (Delay_Index, Loc), 11273 Alternatives => Delay_Alt_List)); 11274 else 11275 Delay_Case := Delay_Alt_List; 11276 end if; 11277 11278 -- If there are no delay alternatives, we append the case statement 11279 -- to the statement list. 11280 11281 if Delay_Count = 0 then 11282 Append_List (Accept_Case, Stats); 11283 11284 -- Delay alternatives present 11285 11286 else 11287 -- If delay alternatives are present we generate: 11288 11289 -- find minimum delay. 11290 -- DX := minimum delay; 11291 -- M := <delay mode>; 11292 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P, 11293 -- DX, MX, X); 11294 -- 11295 -- if X = No_Rendezvous then 11296 -- case statement for delay statements. 11297 -- else 11298 -- case statement for accept alternatives. 11299 -- end if; 11300 11301 declare 11302 Cases : Node_Id; 11303 Stmt : Node_Id; 11304 Parms : List_Id; 11305 Parm : Node_Id; 11306 Conv : Node_Id; 11307 11308 begin 11309 -- The type of the delay expression is known to be legal 11310 11311 if Time_Type = Standard_Duration then 11312 Conv := New_Occurrence_Of (Delay_Min, Loc); 11313 11314 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11315 Conv := Make_Function_Call (Loc, 11316 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 11317 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11318 11319 else 11320 pragma Assert 11321 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11322 11323 Conv := Make_Function_Call (Loc, 11324 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 11325 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11326 end if; 11327 11328 Stmt := Make_Assignment_Statement (Loc, 11329 Name => New_Occurrence_Of (D, Loc), 11330 Expression => Conv); 11331 11332 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) 11333 11334 Parms := Parameter_Associations (Select_Call); 11335 11336 Parm := First (Parms); 11337 while Present (Parm) and then Parm /= Select_Mode loop 11338 Next (Parm); 11339 end loop; 11340 11341 pragma Assert (Present (Parm)); 11342 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc)); 11343 Analyze (Parm); 11344 11345 -- Prepare two new parameters of Duration and Delay_Mode type 11346 -- which represent the value and the mode of the minimum delay. 11347 11348 Next (Parm); 11349 Insert_After (Parm, New_Occurrence_Of (M, Loc)); 11350 Insert_After (Parm, New_Occurrence_Of (D, Loc)); 11351 11352 -- Create a call to RTS 11353 11354 Rewrite (Select_Call, 11355 Make_Procedure_Call_Statement (Loc, 11356 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc), 11357 Parameter_Associations => Parms)); 11358 11359 -- This new call should follow the calculation of the minimum 11360 -- delay. 11361 11362 Insert_List_Before (Select_Call, Delay_List); 11363 11364 if Check_Guard then 11365 Stmt := 11366 Make_Implicit_If_Statement (N, 11367 Condition => New_Occurrence_Of (Guard_Open, Loc), 11368 Then_Statements => New_List ( 11369 New_Copy_Tree (Stmt), 11370 New_Copy_Tree (Select_Call)), 11371 Else_Statements => Accept_Or_Raise); 11372 Rewrite (Select_Call, Stmt); 11373 else 11374 Insert_Before (Select_Call, Stmt); 11375 end if; 11376 11377 Cases := 11378 Make_Implicit_If_Statement (N, 11379 Condition => Make_Op_Eq (Loc, 11380 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 11381 Right_Opnd => 11382 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 11383 11384 Then_Statements => Delay_Case, 11385 Else_Statements => Accept_Case); 11386 11387 Append (Cases, Stats); 11388 end; 11389 end if; 11390 11391 Append (End_Lab, Stats); 11392 11393 -- Replace accept statement with appropriate block 11394 11395 Rewrite (N, 11396 Make_Block_Statement (Loc, 11397 Declarations => Decls, 11398 Handled_Statement_Sequence => 11399 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats))); 11400 Analyze (N); 11401 11402 -- Note: have to worry more about abort deferral in above code ??? 11403 11404 -- Final step is to unstack the Accept_Address entries for all accept 11405 -- statements appearing in accept alternatives in the select statement 11406 11407 Alt := First (Alts); 11408 while Present (Alt) loop 11409 if Nkind (Alt) = N_Accept_Alternative then 11410 Remove_Last_Elmt (Accept_Address 11411 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))); 11412 end if; 11413 11414 Next (Alt); 11415 end loop; 11416 end Expand_N_Selective_Accept; 11417 11418 ------------------------------------------- 11419 -- Expand_N_Single_Protected_Declaration -- 11420 ------------------------------------------- 11421 11422 -- A single protected declaration should never be present after semantic 11423 -- analysis because it is transformed into a protected type declaration 11424 -- and an accompanying anonymous object. This routine ensures that the 11425 -- transformation takes place. 11426 11427 procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is 11428 begin 11429 raise Program_Error; 11430 end Expand_N_Single_Protected_Declaration; 11431 11432 -------------------------------------- 11433 -- Expand_N_Single_Task_Declaration -- 11434 -------------------------------------- 11435 11436 -- A single task declaration should never be present after semantic 11437 -- analysis because it is transformed into a task type declaration and 11438 -- an accompanying anonymous object. This routine ensures that the 11439 -- transformation takes place. 11440 11441 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is 11442 begin 11443 raise Program_Error; 11444 end Expand_N_Single_Task_Declaration; 11445 11446 ------------------------ 11447 -- Expand_N_Task_Body -- 11448 ------------------------ 11449 11450 -- Given a task body 11451 11452 -- task body tname is 11453 -- <declarations> 11454 -- begin 11455 -- <statements> 11456 -- end x; 11457 11458 -- This expansion routine converts it into a procedure and sets the 11459 -- elaboration flag for the procedure to true, to represent the fact 11460 -- that the task body is now elaborated: 11461 11462 -- procedure tnameB (_Task : access tnameV) is 11463 -- discriminal : dtype renames _Task.discriminant; 11464 11465 -- procedure _clean is 11466 -- begin 11467 -- Abort_Defer.all; 11468 -- Complete_Task; 11469 -- Abort_Undefer.all; 11470 -- return; 11471 -- end _clean; 11472 11473 -- begin 11474 -- Abort_Undefer.all; 11475 -- <declarations> 11476 -- System.Task_Stages.Complete_Activation; 11477 -- <statements> 11478 -- at end 11479 -- _clean; 11480 -- end tnameB; 11481 11482 -- tnameE := True; 11483 11484 -- In addition, if the task body is an activator, then a call to activate 11485 -- tasks is added at the start of the statements, before the call to 11486 -- Complete_Activation, and if in addition the task is a master then it 11487 -- must be established as a master. These calls are inserted and analyzed 11488 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is 11489 -- expanded. 11490 11491 -- There is one discriminal declaration line generated for each 11492 -- discriminant that is present to provide an easy reference point for 11493 -- discriminant references inside the body (see Exp_Ch2.Expand_Name). 11494 11495 -- Note on relationship to GNARLI definition. In the GNARLI definition, 11496 -- task body procedures have a profile (Arg : System.Address). That is 11497 -- needed because GNARLI has to use the same access-to-subprogram type 11498 -- for all task types. We depend here on knowing that in GNAT, passing 11499 -- an address argument by value is identical to passing a record value 11500 -- by access (in either case a single pointer is passed), so even though 11501 -- this procedure has the wrong profile. In fact it's all OK, since the 11502 -- callings sequence is identical. 11503 11504 procedure Expand_N_Task_Body (N : Node_Id) is 11505 Loc : constant Source_Ptr := Sloc (N); 11506 Ttyp : constant Entity_Id := Corresponding_Spec (N); 11507 Call : Node_Id; 11508 New_N : Node_Id; 11509 11510 Insert_Nod : Node_Id; 11511 -- Used to determine the proper location of wrapper body insertions 11512 11513 begin 11514 -- if no task body procedure, means we had an error in configurable 11515 -- run-time mode, and there is no point in proceeding further. 11516 11517 if No (Task_Body_Procedure (Ttyp)) then 11518 return; 11519 end if; 11520 11521 -- Add renaming declarations for discriminals and a declaration for the 11522 -- entry family index (if applicable). 11523 11524 Install_Private_Data_Declarations 11525 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N)); 11526 11527 -- Add a call to Abort_Undefer at the very beginning of the task 11528 -- body since this body is called with abort still deferred. 11529 11530 if Abort_Allowed then 11531 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 11532 Insert_Before 11533 (First (Statements (Handled_Statement_Sequence (N))), Call); 11534 Analyze (Call); 11535 end if; 11536 11537 -- The statement part has already been protected with an at_end and 11538 -- cleanup actions. The call to Complete_Activation must be placed 11539 -- at the head of the sequence of statements of that block. The 11540 -- declarations have been merged in this sequence of statements but 11541 -- the first real statement is accessible from the First_Real_Statement 11542 -- field (which was set for exactly this purpose). 11543 11544 if Restricted_Profile then 11545 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); 11546 else 11547 Call := Build_Runtime_Call (Loc, RE_Complete_Activation); 11548 end if; 11549 11550 Insert_Before 11551 (First_Real_Statement (Handled_Statement_Sequence (N)), Call); 11552 Analyze (Call); 11553 11554 New_N := 11555 Make_Subprogram_Body (Loc, 11556 Specification => Build_Task_Proc_Specification (Ttyp), 11557 Declarations => Declarations (N), 11558 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 11559 Set_Is_Task_Body_Procedure (New_N); 11560 11561 -- If the task contains generic instantiations, cleanup actions are 11562 -- delayed until after instantiation. Transfer the activation chain to 11563 -- the subprogram, to insure that the activation call is properly 11564 -- generated. It the task body contains inner tasks, indicate that the 11565 -- subprogram is a task master. 11566 11567 if Delay_Cleanups (Ttyp) then 11568 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); 11569 Set_Is_Task_Master (New_N, Is_Task_Master (N)); 11570 end if; 11571 11572 Rewrite (N, New_N); 11573 Analyze (N); 11574 11575 -- Set elaboration flag immediately after task body. If the body is a 11576 -- subunit, the flag is set in the declarative part containing the stub. 11577 11578 if Nkind (Parent (N)) /= N_Subunit then 11579 Insert_After (N, 11580 Make_Assignment_Statement (Loc, 11581 Name => 11582 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), 11583 Expression => New_Occurrence_Of (Standard_True, Loc))); 11584 end if; 11585 11586 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after 11587 -- the task body. At this point all wrapper specs have been created, 11588 -- frozen and included in the dispatch table for the task type. 11589 11590 if Ada_Version >= Ada_2005 then 11591 if Nkind (Parent (N)) = N_Subunit then 11592 Insert_Nod := Corresponding_Stub (Parent (N)); 11593 else 11594 Insert_Nod := N; 11595 end if; 11596 11597 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod); 11598 end if; 11599 end Expand_N_Task_Body; 11600 11601 ------------------------------------ 11602 -- Expand_N_Task_Type_Declaration -- 11603 ------------------------------------ 11604 11605 -- We have several things to do. First we must create a Boolean flag used 11606 -- to mark if the body is elaborated yet. This variable gets set to True 11607 -- when the body of the task is elaborated (we can't rely on the normal 11608 -- ABE mechanism for the task body, since we need to pass an access to 11609 -- this elaboration boolean to the runtime routines). 11610 11611 -- taskE : aliased Boolean := False; 11612 11613 -- Next a variable is declared to hold the task stack size (either the 11614 -- default : Unspecified_Size, or a value that is set by a pragma 11615 -- Storage_Size). If the value of the pragma Storage_Size is static, then 11616 -- the variable is initialized with this value: 11617 11618 -- taskZ : Size_Type := Unspecified_Size; 11619 -- or 11620 -- taskZ : Size_Type := Size_Type (size_expression); 11621 11622 -- Note: No variable is needed to hold the task relative deadline since 11623 -- its value would never be static because the parameter is of a private 11624 -- type (Ada.Real_Time.Time_Span). 11625 11626 -- Next we create a corresponding record type declaration used to represent 11627 -- values of this task. The general form of this type declaration is 11628 11629 -- type taskV (discriminants) is record 11630 -- _Task_Id : Task_Id; 11631 -- entry_family : array (bounds) of Void; 11632 -- _Priority : Integer := priority_expression; 11633 -- _Size : Size_Type := size_expression; 11634 -- _Secondary_Stack_Size : Size_Type := size_expression; 11635 -- _Task_Info : Task_Info_Type := task_info_expression; 11636 -- _CPU : Integer := cpu_range_expression; 11637 -- _Relative_Deadline : Time_Span := time_span_expression; 11638 -- _Domain : Dispatching_Domain := dd_expression; 11639 -- end record; 11640 11641 -- The discriminants are present only if the corresponding task type has 11642 -- discriminants, and they exactly mirror the task type discriminants. 11643 11644 -- The Id field is always present. It contains the Task_Id value, as set by 11645 -- the call to Create_Task. Note that although the task is limited, the 11646 -- task value record type is not limited, so there is no problem in passing 11647 -- this field as an out parameter to Create_Task. 11648 11649 -- One entry_family component is present for each entry family in the task 11650 -- definition. The bounds correspond to the bounds of the entry family 11651 -- (which may depend on discriminants). The element type is void, since we 11652 -- only need the bounds information for determining the entry index. Note 11653 -- that the use of an anonymous array would normally be illegal in this 11654 -- context, but this is a parser check, and the semantics is quite prepared 11655 -- to handle such a case. 11656 11657 -- The _Size field is present only if a Storage_Size pragma appears in the 11658 -- task definition. The expression captures the argument that was present 11659 -- in the pragma, and is used to override the task stack size otherwise 11660 -- associated with the task type. 11661 11662 -- The _Secondary_Stack_Size field is present only the task entity has a 11663 -- Secondary_Stack_Size rep item. It will be filled at the freeze point, 11664 -- when the record init proc is built, to capture the expression of the 11665 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot 11666 -- be filled here since aspect evaluations are delayed till the freeze 11667 -- point. 11668 11669 -- The _Priority field is present only if the task entity has a Priority or 11670 -- Interrupt_Priority rep item (pragma, aspect specification or attribute 11671 -- definition clause). It will be filled at the freeze point, when the 11672 -- record init proc is built, to capture the expression of the rep item 11673 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11674 -- here since aspect evaluations are delayed till the freeze point. 11675 11676 -- The _Task_Info field is present only if a Task_Info pragma appears in 11677 -- the task definition. The expression captures the argument that was 11678 -- present in the pragma, and is used to provide the Task_Image parameter 11679 -- to the call to Create_Task. 11680 11681 -- The _CPU field is present only if the task entity has a CPU rep item 11682 -- (pragma, aspect specification or attribute definition clause). It will 11683 -- be filled at the freeze point, when the record init proc is built, to 11684 -- capture the expression of the rep item (see Build_Record_Init_Proc in 11685 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations 11686 -- are delayed till the freeze point. 11687 11688 -- The _Relative_Deadline field is present only if a Relative_Deadline 11689 -- pragma appears in the task definition. The expression captures the 11690 -- argument that was present in the pragma, and is used to provide the 11691 -- Relative_Deadline parameter to the call to Create_Task. 11692 11693 -- The _Domain field is present only if the task entity has a 11694 -- Dispatching_Domain rep item (pragma, aspect specification or attribute 11695 -- definition clause). It will be filled at the freeze point, when the 11696 -- record init proc is built, to capture the expression of the rep item 11697 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11698 -- here since aspect evaluations are delayed till the freeze point. 11699 11700 -- When a task is declared, an instance of the task value record is 11701 -- created. The elaboration of this declaration creates the correct bounds 11702 -- for the entry families, and also evaluates the size, priority, and 11703 -- task_Info expressions if needed. The initialization routine for the task 11704 -- type itself then calls Create_Task with appropriate parameters to 11705 -- initialize the value of the Task_Id field. 11706 11707 -- Note: the address of this record is passed as the "Discriminants" 11708 -- parameter for Create_Task. Since Create_Task merely passes this onto the 11709 -- body procedure, it does not matter that it does not quite match the 11710 -- GNARLI model of what is being passed (the record contains more than just 11711 -- the discriminants, but the discriminants can be found from the record 11712 -- value). 11713 11714 -- The Entity_Id for this created record type is placed in the 11715 -- Corresponding_Record_Type field of the associated task type entity. 11716 11717 -- Next we create a procedure specification for the task body procedure: 11718 11719 -- procedure taskB (_Task : access taskV); 11720 11721 -- Note that this must come after the record type declaration, since 11722 -- the spec refers to this type. It turns out that the initialization 11723 -- procedure for the value type references the task body spec, but that's 11724 -- fine, since it won't be generated till the freeze point for the type, 11725 -- which is certainly after the task body spec declaration. 11726 11727 -- Finally, we set the task index value field of the entry attribute in 11728 -- the case of a simple entry. 11729 11730 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is 11731 Loc : constant Source_Ptr := Sloc (N); 11732 TaskId : constant Entity_Id := Defining_Identifier (N); 11733 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); 11734 Tasknm : constant Name_Id := Chars (Tasktyp); 11735 Taskdef : constant Node_Id := Task_Definition (N); 11736 11737 Body_Decl : Node_Id; 11738 Cdecls : List_Id; 11739 Decl_Stack : Node_Id; 11740 Decl_SS : Node_Id; 11741 Elab_Decl : Node_Id; 11742 Ent_Stack : Entity_Id; 11743 Proc_Spec : Node_Id; 11744 Rec_Decl : Node_Id; 11745 Rec_Ent : Entity_Id; 11746 Size_Decl : Entity_Id; 11747 Task_Size : Node_Id; 11748 11749 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id; 11750 -- Searches the task definition T for the first occurrence of the pragma 11751 -- Relative Deadline. The caller has ensured that the pragma is present 11752 -- in the task definition. Note that this routine cannot be implemented 11753 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are 11754 -- not chained because their expansion into a procedure call statement 11755 -- would cause a break in the chain. 11756 11757 ---------------------------------- 11758 -- Get_Relative_Deadline_Pragma -- 11759 ---------------------------------- 11760 11761 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is 11762 N : Node_Id; 11763 11764 begin 11765 N := First (Visible_Declarations (T)); 11766 while Present (N) loop 11767 if Nkind (N) = N_Pragma 11768 and then Pragma_Name (N) = Name_Relative_Deadline 11769 then 11770 return N; 11771 end if; 11772 11773 Next (N); 11774 end loop; 11775 11776 N := First (Private_Declarations (T)); 11777 while Present (N) loop 11778 if Nkind (N) = N_Pragma 11779 and then Pragma_Name (N) = Name_Relative_Deadline 11780 then 11781 return N; 11782 end if; 11783 11784 Next (N); 11785 end loop; 11786 11787 raise Program_Error; 11788 end Get_Relative_Deadline_Pragma; 11789 11790 -- Start of processing for Expand_N_Task_Type_Declaration 11791 11792 begin 11793 -- If already expanded, nothing to do 11794 11795 if Present (Corresponding_Record_Type (Tasktyp)) then 11796 return; 11797 end if; 11798 11799 -- Here we will do the expansion 11800 11801 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); 11802 11803 Rec_Ent := Defining_Identifier (Rec_Decl); 11804 Cdecls := Component_Items (Component_List 11805 (Type_Definition (Rec_Decl))); 11806 11807 Qualify_Entity_Names (N); 11808 11809 -- First create the elaboration variable 11810 11811 Elab_Decl := 11812 Make_Object_Declaration (Loc, 11813 Defining_Identifier => 11814 Make_Defining_Identifier (Sloc (Tasktyp), 11815 Chars => New_External_Name (Tasknm, 'E')), 11816 Aliased_Present => True, 11817 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 11818 Expression => New_Occurrence_Of (Standard_False, Loc)); 11819 11820 Insert_After (N, Elab_Decl); 11821 11822 -- Next create the declaration of the size variable (tasknmZ) 11823 11824 Set_Storage_Size_Variable (Tasktyp, 11825 Make_Defining_Identifier (Sloc (Tasktyp), 11826 Chars => New_External_Name (Tasknm, 'Z'))); 11827 11828 if Present (Taskdef) 11829 and then Has_Storage_Size_Pragma (Taskdef) 11830 and then 11831 Is_OK_Static_Expression 11832 (Expression 11833 (First (Pragma_Argument_Associations 11834 (Get_Rep_Pragma (TaskId, Name_Storage_Size))))) 11835 then 11836 Size_Decl := 11837 Make_Object_Declaration (Loc, 11838 Defining_Identifier => Storage_Size_Variable (Tasktyp), 11839 Object_Definition => 11840 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 11841 Expression => 11842 Convert_To (RTE (RE_Size_Type), 11843 Relocate_Node 11844 (Expression (First (Pragma_Argument_Associations 11845 (Get_Rep_Pragma 11846 (TaskId, Name_Storage_Size))))))); 11847 11848 else 11849 Size_Decl := 11850 Make_Object_Declaration (Loc, 11851 Defining_Identifier => Storage_Size_Variable (Tasktyp), 11852 Object_Definition => 11853 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 11854 Expression => 11855 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 11856 end if; 11857 11858 Insert_After (Elab_Decl, Size_Decl); 11859 11860 -- Next build the rest of the corresponding record declaration. This is 11861 -- done last, since the corresponding record initialization procedure 11862 -- will reference the previously created entities. 11863 11864 -- Fill in the component declarations -- first the _Task_Id field 11865 11866 Append_To (Cdecls, 11867 Make_Component_Declaration (Loc, 11868 Defining_Identifier => 11869 Make_Defining_Identifier (Loc, Name_uTask_Id), 11870 Component_Definition => 11871 Make_Component_Definition (Loc, 11872 Aliased_Present => False, 11873 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id), 11874 Loc)))); 11875 11876 -- Declare static ATCB (that is, created by the expander) if we are 11877 -- using the Restricted run time. 11878 11879 if Restricted_Profile then 11880 Append_To (Cdecls, 11881 Make_Component_Declaration (Loc, 11882 Defining_Identifier => 11883 Make_Defining_Identifier (Loc, Name_uATCB), 11884 11885 Component_Definition => 11886 Make_Component_Definition (Loc, 11887 Aliased_Present => True, 11888 Subtype_Indication => Make_Subtype_Indication (Loc, 11889 Subtype_Mark => 11890 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc), 11891 11892 Constraint => 11893 Make_Index_Or_Discriminant_Constraint (Loc, 11894 Constraints => 11895 New_List (Make_Integer_Literal (Loc, 0))))))); 11896 11897 end if; 11898 11899 -- Declare static stack (that is, created by the expander) if we are 11900 -- using the Restricted run time on a bare board configuration. 11901 11902 if Restricted_Profile and then Preallocated_Stacks_On_Target then 11903 11904 -- First we need to extract the appropriate stack size 11905 11906 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack); 11907 11908 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 11909 declare 11910 Expr_N : constant Node_Id := 11911 Expression (First ( 11912 Pragma_Argument_Associations ( 11913 Get_Rep_Pragma (TaskId, Name_Storage_Size)))); 11914 Etyp : constant Entity_Id := Etype (Expr_N); 11915 P : constant Node_Id := Parent (Expr_N); 11916 11917 begin 11918 -- The stack is defined inside the corresponding record. 11919 -- Therefore if the size of the stack is set by means of 11920 -- a discriminant, we must reference the discriminant of the 11921 -- corresponding record type. 11922 11923 if Nkind (Expr_N) in N_Has_Entity 11924 and then Present (Discriminal_Link (Entity (Expr_N))) 11925 then 11926 Task_Size := 11927 New_Occurrence_Of 11928 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))), 11929 Loc); 11930 Set_Parent (Task_Size, P); 11931 Set_Etype (Task_Size, Etyp); 11932 Set_Analyzed (Task_Size); 11933 11934 else 11935 Task_Size := New_Copy_Tree (Expr_N); 11936 end if; 11937 end; 11938 11939 else 11940 Task_Size := 11941 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc); 11942 end if; 11943 11944 Decl_Stack := Make_Component_Declaration (Loc, 11945 Defining_Identifier => Ent_Stack, 11946 11947 Component_Definition => 11948 Make_Component_Definition (Loc, 11949 Aliased_Present => True, 11950 Subtype_Indication => Make_Subtype_Indication (Loc, 11951 Subtype_Mark => 11952 New_Occurrence_Of (RTE (RE_Storage_Array), Loc), 11953 11954 Constraint => 11955 Make_Index_Or_Discriminant_Constraint (Loc, 11956 Constraints => New_List (Make_Range (Loc, 11957 Low_Bound => Make_Integer_Literal (Loc, 1), 11958 High_Bound => Convert_To (RTE (RE_Storage_Offset), 11959 Task_Size))))))); 11960 11961 Append_To (Cdecls, Decl_Stack); 11962 11963 -- The appropriate alignment for the stack is ensured by the run-time 11964 -- code in charge of task creation. 11965 11966 end if; 11967 11968 -- Declare a static secondary stack if the conditions for a statically 11969 -- generated stack are met. 11970 11971 if Create_Secondary_Stack_For_Task (TaskId) then 11972 declare 11973 Size_Expr : constant Node_Id := 11974 Expression (First ( 11975 Pragma_Argument_Associations ( 11976 Get_Rep_Pragma (TaskId, 11977 Name_Secondary_Stack_Size)))); 11978 11979 Stack_Size : Node_Id; 11980 11981 begin 11982 -- The secondary stack is defined inside the corresponding 11983 -- record. Therefore if the size of the stack is set by means 11984 -- of a discriminant, we must reference the discriminant of the 11985 -- corresponding record type. 11986 11987 if Nkind (Size_Expr) in N_Has_Entity 11988 and then Present (Discriminal_Link (Entity (Size_Expr))) 11989 then 11990 Stack_Size := 11991 New_Occurrence_Of 11992 (CR_Discriminant (Discriminal_Link (Entity (Size_Expr))), 11993 Loc); 11994 Set_Parent (Stack_Size, Parent (Size_Expr)); 11995 Set_Etype (Stack_Size, Etype (Size_Expr)); 11996 Set_Analyzed (Stack_Size); 11997 11998 else 11999 Stack_Size := New_Copy_Tree (Size_Expr); 12000 end if; 12001 12002 -- Create the secondary stack for the task 12003 12004 Decl_SS := 12005 Make_Component_Declaration (Loc, 12006 Defining_Identifier => 12007 Make_Defining_Identifier (Loc, Name_uSecondary_Stack), 12008 Component_Definition => 12009 Make_Component_Definition (Loc, 12010 Aliased_Present => True, 12011 Subtype_Indication => 12012 Make_Subtype_Indication (Loc, 12013 Subtype_Mark => 12014 New_Occurrence_Of (RTE (RE_SS_Stack), Loc), 12015 Constraint => 12016 Make_Index_Or_Discriminant_Constraint (Loc, 12017 Constraints => New_List ( 12018 Convert_To (RTE (RE_Size_Type), 12019 Stack_Size)))))); 12020 12021 Append_To (Cdecls, Decl_SS); 12022 end; 12023 end if; 12024 12025 -- Add components for entry families 12026 12027 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); 12028 12029 -- Add the _Priority component if a Interrupt_Priority or Priority rep 12030 -- item is present. 12031 12032 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then 12033 Append_To (Cdecls, 12034 Make_Component_Declaration (Loc, 12035 Defining_Identifier => 12036 Make_Defining_Identifier (Loc, Name_uPriority), 12037 Component_Definition => 12038 Make_Component_Definition (Loc, 12039 Aliased_Present => False, 12040 Subtype_Indication => 12041 New_Occurrence_Of (Standard_Integer, Loc)))); 12042 end if; 12043 12044 -- Add the _Size component if a Storage_Size pragma is present 12045 12046 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 12047 Append_To (Cdecls, 12048 Make_Component_Declaration (Loc, 12049 Defining_Identifier => 12050 Make_Defining_Identifier (Loc, Name_uSize), 12051 12052 Component_Definition => 12053 Make_Component_Definition (Loc, 12054 Aliased_Present => False, 12055 Subtype_Indication => 12056 New_Occurrence_Of (RTE (RE_Size_Type), Loc)), 12057 12058 Expression => 12059 Convert_To (RTE (RE_Size_Type), 12060 New_Copy_Tree ( 12061 Expression (First ( 12062 Pragma_Argument_Associations ( 12063 Get_Rep_Pragma (TaskId, Name_Storage_Size)))))))); 12064 end if; 12065 12066 -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size 12067 -- pragma is present. 12068 12069 if Has_Rep_Pragma 12070 (TaskId, Name_Secondary_Stack_Size, Check_Parents => False) 12071 then 12072 Append_To (Cdecls, 12073 Make_Component_Declaration (Loc, 12074 Defining_Identifier => 12075 Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size), 12076 12077 Component_Definition => 12078 Make_Component_Definition (Loc, 12079 Aliased_Present => False, 12080 Subtype_Indication => 12081 New_Occurrence_Of (RTE (RE_Size_Type), Loc)))); 12082 end if; 12083 12084 -- Add the _Task_Info component if a Task_Info pragma is present 12085 12086 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then 12087 Append_To (Cdecls, 12088 Make_Component_Declaration (Loc, 12089 Defining_Identifier => 12090 Make_Defining_Identifier (Loc, Name_uTask_Info), 12091 12092 Component_Definition => 12093 Make_Component_Definition (Loc, 12094 Aliased_Present => False, 12095 Subtype_Indication => 12096 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)), 12097 12098 Expression => New_Copy ( 12099 Expression (First ( 12100 Pragma_Argument_Associations ( 12101 Get_Rep_Pragma 12102 (TaskId, Name_Task_Info, Check_Parents => False))))))); 12103 end if; 12104 12105 -- Add the _CPU component if a CPU rep item is present 12106 12107 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then 12108 Append_To (Cdecls, 12109 Make_Component_Declaration (Loc, 12110 Defining_Identifier => 12111 Make_Defining_Identifier (Loc, Name_uCPU), 12112 12113 Component_Definition => 12114 Make_Component_Definition (Loc, 12115 Aliased_Present => False, 12116 Subtype_Indication => 12117 New_Occurrence_Of (RTE (RE_CPU_Range), Loc)))); 12118 end if; 12119 12120 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is 12121 -- present. If we are using a restricted run time this component will 12122 -- not be added (deadlines are not allowed by the Ravenscar profile), 12123 -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF 12124 -- profile). 12125 12126 if (not Restricted_Profile or else Task_Dispatching_Policy = 'E') 12127 and then Present (Taskdef) 12128 and then Has_Relative_Deadline_Pragma (Taskdef) 12129 then 12130 Append_To (Cdecls, 12131 Make_Component_Declaration (Loc, 12132 Defining_Identifier => 12133 Make_Defining_Identifier (Loc, Name_uRelative_Deadline), 12134 12135 Component_Definition => 12136 Make_Component_Definition (Loc, 12137 Aliased_Present => False, 12138 Subtype_Indication => 12139 New_Occurrence_Of (RTE (RE_Time_Span), Loc)), 12140 12141 Expression => 12142 Convert_To (RTE (RE_Time_Span), 12143 New_Copy_Tree ( 12144 Expression (First ( 12145 Pragma_Argument_Associations ( 12146 Get_Relative_Deadline_Pragma (Taskdef)))))))); 12147 end if; 12148 12149 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep 12150 -- item is present. If we are using a restricted run time this component 12151 -- will not be added (dispatching domains are not allowed by the 12152 -- Ravenscar profile). 12153 12154 if not Restricted_Profile 12155 and then 12156 Has_Rep_Item 12157 (TaskId, Name_Dispatching_Domain, Check_Parents => False) 12158 then 12159 Append_To (Cdecls, 12160 Make_Component_Declaration (Loc, 12161 Defining_Identifier => 12162 Make_Defining_Identifier (Loc, Name_uDispatching_Domain), 12163 12164 Component_Definition => 12165 Make_Component_Definition (Loc, 12166 Aliased_Present => False, 12167 Subtype_Indication => 12168 New_Occurrence_Of 12169 (RTE (RE_Dispatching_Domain_Access), Loc)))); 12170 end if; 12171 12172 Insert_After (Size_Decl, Rec_Decl); 12173 12174 -- Analyze the record declaration immediately after construction, 12175 -- because the initialization procedure is needed for single task 12176 -- declarations before the next entity is analyzed. 12177 12178 Analyze (Rec_Decl); 12179 12180 -- Create the declaration of the task body procedure 12181 12182 Proc_Spec := Build_Task_Proc_Specification (Tasktyp); 12183 Body_Decl := 12184 Make_Subprogram_Declaration (Loc, 12185 Specification => Proc_Spec); 12186 Set_Is_Task_Body_Procedure (Body_Decl); 12187 12188 Insert_After (Rec_Decl, Body_Decl); 12189 12190 -- The subprogram does not comes from source, so we have to indicate the 12191 -- need for debugging information explicitly. 12192 12193 if Comes_From_Source (Original_Node (N)) then 12194 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec)); 12195 end if; 12196 12197 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before 12198 -- the corresponding record has been frozen. 12199 12200 if Ada_Version >= Ada_2005 then 12201 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl); 12202 end if; 12203 12204 -- Ada 2005 (AI-345): We must defer freezing to allow further 12205 -- declaration of primitive subprograms covering task interfaces 12206 12207 if Ada_Version <= Ada_95 then 12208 12209 -- Now we can freeze the corresponding record. This needs manually 12210 -- freezing, since it is really part of the task type, and the task 12211 -- type is frozen at this stage. We of course need the initialization 12212 -- procedure for this corresponding record type and we won't get it 12213 -- in time if we don't freeze now. 12214 12215 declare 12216 L : constant List_Id := Freeze_Entity (Rec_Ent, N); 12217 begin 12218 if Is_Non_Empty_List (L) then 12219 Insert_List_After (Body_Decl, L); 12220 end if; 12221 end; 12222 end if; 12223 12224 -- Complete the expansion of access types to the current task type, if 12225 -- any were declared. 12226 12227 Expand_Previous_Access_Type (Tasktyp); 12228 12229 -- Create wrappers for entries that have contract cases, preconditions 12230 -- and postconditions. 12231 12232 declare 12233 Ent : Entity_Id; 12234 12235 begin 12236 Ent := First_Entity (Tasktyp); 12237 while Present (Ent) loop 12238 if Ekind_In (Ent, E_Entry, E_Entry_Family) then 12239 Build_Contract_Wrapper (Ent, N); 12240 end if; 12241 12242 Next_Entity (Ent); 12243 end loop; 12244 end; 12245 end Expand_N_Task_Type_Declaration; 12246 12247 ------------------------------- 12248 -- Expand_N_Timed_Entry_Call -- 12249 ------------------------------- 12250 12251 -- A timed entry call in normal case is not implemented using ATC mechanism 12252 -- anymore for efficiency reason. 12253 12254 -- select 12255 -- T.E; 12256 -- S1; 12257 -- or 12258 -- delay D; 12259 -- S2; 12260 -- end select; 12261 12262 -- is expanded as follows: 12263 12264 -- 1) When T.E is a task entry_call; 12265 12266 -- declare 12267 -- B : Boolean; 12268 -- X : Task_Entry_Index := <entry index>; 12269 -- DX : Duration := To_Duration (D); 12270 -- M : Delay_Mode := <discriminant>; 12271 -- P : parms := (parm, parm, parm); 12272 12273 -- begin 12274 -- Timed_Protected_Entry_Call 12275 -- (<acceptor-task>, X, P'Address, DX, M, B); 12276 -- if B then 12277 -- S1; 12278 -- else 12279 -- S2; 12280 -- end if; 12281 -- end; 12282 12283 -- 2) When T.E is a protected entry_call; 12284 12285 -- declare 12286 -- B : Boolean; 12287 -- X : Protected_Entry_Index := <entry index>; 12288 -- DX : Duration := To_Duration (D); 12289 -- M : Delay_Mode := <discriminant>; 12290 -- P : parms := (parm, parm, parm); 12291 12292 -- begin 12293 -- Timed_Protected_Entry_Call 12294 -- (<object>'unchecked_access, X, P'Address, DX, M, B); 12295 -- if B then 12296 -- S1; 12297 -- else 12298 -- S2; 12299 -- end if; 12300 -- end; 12301 12302 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there 12303 -- is no delay and the triggering statements are executed. We first 12304 -- determine the kind of the triggering call and then execute a 12305 -- synchronized operation or a direct call. 12306 12307 -- declare 12308 -- B : Boolean := False; 12309 -- C : Ada.Tags.Prim_Op_Kind; 12310 -- DX : Duration := To_Duration (D) 12311 -- K : Ada.Tags.Tagged_Kind := 12312 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 12313 -- M : Integer :=...; 12314 -- P : Parameters := (Param1 .. ParamN); 12315 -- S : Integer; 12316 12317 -- begin 12318 -- if K = Ada.Tags.TK_Limited_Tagged 12319 -- or else K = Ada.Tags.TK_Tagged 12320 -- then 12321 -- <dispatching-call>; 12322 -- B := True; 12323 12324 -- else 12325 -- S := 12326 -- Ada.Tags.Get_Offset_Index 12327 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 12328 12329 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B); 12330 12331 -- if C = POK_Protected_Entry 12332 -- or else C = POK_Task_Entry 12333 -- then 12334 -- Param1 := P.Param1; 12335 -- ... 12336 -- ParamN := P.ParamN; 12337 -- end if; 12338 12339 -- if B then 12340 -- if C = POK_Procedure 12341 -- or else C = POK_Protected_Procedure 12342 -- or else C = POK_Task_Procedure 12343 -- then 12344 -- <dispatching-call>; 12345 -- end if; 12346 -- end if; 12347 -- end if; 12348 12349 -- if B then 12350 -- <triggering-statements> 12351 -- else 12352 -- <timed-statements> 12353 -- end if; 12354 -- end; 12355 12356 -- The triggering statement and the sequence of timed statements have not 12357 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain 12358 -- global references if within an instantiation. 12359 12360 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is 12361 Loc : constant Source_Ptr := Sloc (N); 12362 12363 Actuals : List_Id; 12364 Blk_Typ : Entity_Id; 12365 Call : Node_Id; 12366 Call_Ent : Entity_Id; 12367 Conc_Typ_Stmts : List_Id; 12368 Concval : Node_Id := Empty; -- init to avoid warning 12369 D_Alt : constant Node_Id := Delay_Alternative (N); 12370 D_Conv : Node_Id; 12371 D_Disc : Node_Id; 12372 D_Stat : Node_Id := Delay_Statement (D_Alt); 12373 D_Stats : List_Id; 12374 D_Type : Entity_Id; 12375 Decls : List_Id; 12376 Dummy : Node_Id; 12377 E_Alt : constant Node_Id := Entry_Call_Alternative (N); 12378 E_Call : Node_Id := Entry_Call_Statement (E_Alt); 12379 E_Stats : List_Id; 12380 Ename : Node_Id; 12381 Formals : List_Id; 12382 Index : Node_Id; 12383 Is_Disp_Select : Boolean; 12384 Lim_Typ_Stmts : List_Id; 12385 N_Stats : List_Id; 12386 Obj : Entity_Id; 12387 Param : Node_Id; 12388 Params : List_Id; 12389 Stmt : Node_Id; 12390 Stmts : List_Id; 12391 Unpack : List_Id; 12392 12393 B : Entity_Id; -- Call status flag 12394 C : Entity_Id; -- Call kind 12395 D : Entity_Id; -- Delay 12396 K : Entity_Id; -- Tagged kind 12397 M : Entity_Id; -- Delay mode 12398 P : Entity_Id; -- Parameter block 12399 S : Entity_Id; -- Primitive operation slot 12400 12401 -- Start of processing for Expand_N_Timed_Entry_Call 12402 12403 begin 12404 -- Under the Ravenscar profile, timed entry calls are excluded. An error 12405 -- was already reported on spec, so do not attempt to expand the call. 12406 12407 if Restriction_Active (No_Select_Statements) then 12408 return; 12409 end if; 12410 12411 Process_Statements_For_Controlled_Objects (E_Alt); 12412 Process_Statements_For_Controlled_Objects (D_Alt); 12413 12414 Ensure_Statement_Present (Sloc (D_Stat), D_Alt); 12415 12416 -- Retrieve E_Stats and D_Stats now because the finalization machinery 12417 -- may wrap them in blocks. 12418 12419 E_Stats := Statements (E_Alt); 12420 D_Stats := Statements (D_Alt); 12421 12422 -- The arguments in the call may require dynamic allocation, and the 12423 -- call statement may have been transformed into a block. The block 12424 -- may contain additional declarations for internal entities, and the 12425 -- original call is found by sequential search. 12426 12427 if Nkind (E_Call) = N_Block_Statement then 12428 E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); 12429 while not Nkind_In (E_Call, N_Procedure_Call_Statement, 12430 N_Entry_Call_Statement) 12431 loop 12432 Next (E_Call); 12433 end loop; 12434 end if; 12435 12436 Is_Disp_Select := 12437 Ada_Version >= Ada_2005 12438 and then Nkind (E_Call) = N_Procedure_Call_Statement; 12439 12440 if Is_Disp_Select then 12441 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals); 12442 Decls := New_List; 12443 12444 Stmts := New_List; 12445 12446 -- Generate: 12447 -- B : Boolean := False; 12448 12449 B := Build_B (Loc, Decls); 12450 12451 -- Generate: 12452 -- C : Ada.Tags.Prim_Op_Kind; 12453 12454 C := Build_C (Loc, Decls); 12455 12456 -- Because the analysis of all statements was disabled, manually 12457 -- analyze the delay statement. 12458 12459 Analyze (D_Stat); 12460 D_Stat := Original_Node (D_Stat); 12461 12462 else 12463 -- Build an entry call using Simple_Entry_Call 12464 12465 Extract_Entry (E_Call, Concval, Ename, Index); 12466 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); 12467 12468 Decls := Declarations (E_Call); 12469 Stmts := Statements (Handled_Statement_Sequence (E_Call)); 12470 12471 if No (Decls) then 12472 Decls := New_List; 12473 end if; 12474 12475 -- Generate: 12476 -- B : Boolean; 12477 12478 B := Make_Defining_Identifier (Loc, Name_uB); 12479 12480 Prepend_To (Decls, 12481 Make_Object_Declaration (Loc, 12482 Defining_Identifier => B, 12483 Object_Definition => 12484 New_Occurrence_Of (Standard_Boolean, Loc))); 12485 end if; 12486 12487 -- Duration and mode processing 12488 12489 D_Type := Base_Type (Etype (Expression (D_Stat))); 12490 12491 -- Use the type of the delay expression (Calendar or Real_Time) to 12492 -- generate the appropriate conversion. 12493 12494 if Nkind (D_Stat) = N_Delay_Relative_Statement then 12495 D_Disc := Make_Integer_Literal (Loc, 0); 12496 D_Conv := Relocate_Node (Expression (D_Stat)); 12497 12498 elsif Is_RTE (D_Type, RO_CA_Time) then 12499 D_Disc := Make_Integer_Literal (Loc, 1); 12500 D_Conv := 12501 Make_Function_Call (Loc, 12502 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 12503 Parameter_Associations => 12504 New_List (New_Copy (Expression (D_Stat)))); 12505 12506 else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); 12507 D_Disc := Make_Integer_Literal (Loc, 2); 12508 D_Conv := 12509 Make_Function_Call (Loc, 12510 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 12511 Parameter_Associations => 12512 New_List (New_Copy (Expression (D_Stat)))); 12513 end if; 12514 12515 D := Make_Temporary (Loc, 'D'); 12516 12517 -- Generate: 12518 -- D : Duration; 12519 12520 Append_To (Decls, 12521 Make_Object_Declaration (Loc, 12522 Defining_Identifier => D, 12523 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc))); 12524 12525 M := Make_Temporary (Loc, 'M'); 12526 12527 -- Generate: 12528 -- M : Integer := (0 | 1 | 2); 12529 12530 Append_To (Decls, 12531 Make_Object_Declaration (Loc, 12532 Defining_Identifier => M, 12533 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 12534 Expression => D_Disc)); 12535 12536 -- Do the assignment at this stage only because the evaluation of the 12537 -- expression must not occur before (see ACVC C97302A). 12538 12539 Append_To (Stmts, 12540 Make_Assignment_Statement (Loc, 12541 Name => New_Occurrence_Of (D, Loc), 12542 Expression => D_Conv)); 12543 12544 -- Parameter block processing 12545 12546 -- Manually create the parameter block for dispatching calls. In the 12547 -- case of entries, the block has already been created during the call 12548 -- to Build_Simple_Entry_Call. 12549 12550 if Is_Disp_Select then 12551 12552 -- Tagged kind processing, generate: 12553 -- K : Ada.Tags.Tagged_Kind := 12554 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>)); 12555 12556 K := Build_K (Loc, Decls, Obj); 12557 12558 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 12559 P := 12560 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 12561 12562 -- Dispatch table slot processing, generate: 12563 -- S : Integer; 12564 12565 S := Build_S (Loc, Decls); 12566 12567 -- Generate: 12568 -- S := Ada.Tags.Get_Offset_Index 12569 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 12570 12571 Conc_Typ_Stmts := 12572 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 12573 12574 -- Generate: 12575 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B); 12576 12577 -- where Obj is the controlling formal parameter, S is the dispatch 12578 -- table slot number of the dispatching operation, P is the wrapped 12579 -- parameter block, D is the duration, M is the duration mode, C is 12580 -- the call kind and B is the call status. 12581 12582 Params := New_List; 12583 12584 Append_To (Params, New_Copy_Tree (Obj)); 12585 Append_To (Params, New_Occurrence_Of (S, Loc)); 12586 Append_To (Params, 12587 Make_Attribute_Reference (Loc, 12588 Prefix => New_Occurrence_Of (P, Loc), 12589 Attribute_Name => Name_Address)); 12590 Append_To (Params, New_Occurrence_Of (D, Loc)); 12591 Append_To (Params, New_Occurrence_Of (M, Loc)); 12592 Append_To (Params, New_Occurrence_Of (C, Loc)); 12593 Append_To (Params, New_Occurrence_Of (B, Loc)); 12594 12595 Append_To (Conc_Typ_Stmts, 12596 Make_Procedure_Call_Statement (Loc, 12597 Name => 12598 New_Occurrence_Of 12599 (Find_Prim_Op 12600 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc), 12601 Parameter_Associations => Params)); 12602 12603 -- Generate: 12604 -- if C = POK_Protected_Entry 12605 -- or else C = POK_Task_Entry 12606 -- then 12607 -- Param1 := P.Param1; 12608 -- ... 12609 -- ParamN := P.ParamN; 12610 -- end if; 12611 12612 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 12613 12614 -- Generate the if statement only when the packed parameters need 12615 -- explicit assignments to their corresponding actuals. 12616 12617 if Present (Unpack) then 12618 Append_To (Conc_Typ_Stmts, 12619 Make_Implicit_If_Statement (N, 12620 12621 Condition => 12622 Make_Or_Else (Loc, 12623 Left_Opnd => 12624 Make_Op_Eq (Loc, 12625 Left_Opnd => New_Occurrence_Of (C, Loc), 12626 Right_Opnd => 12627 New_Occurrence_Of 12628 (RTE (RE_POK_Protected_Entry), Loc)), 12629 12630 Right_Opnd => 12631 Make_Op_Eq (Loc, 12632 Left_Opnd => New_Occurrence_Of (C, Loc), 12633 Right_Opnd => 12634 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 12635 12636 Then_Statements => Unpack)); 12637 end if; 12638 12639 -- Generate: 12640 12641 -- if B then 12642 -- if C = POK_Procedure 12643 -- or else C = POK_Protected_Procedure 12644 -- or else C = POK_Task_Procedure 12645 -- then 12646 -- <dispatching-call> 12647 -- end if; 12648 -- end if; 12649 12650 N_Stats := New_List ( 12651 Make_Implicit_If_Statement (N, 12652 Condition => 12653 Make_Or_Else (Loc, 12654 Left_Opnd => 12655 Make_Op_Eq (Loc, 12656 Left_Opnd => New_Occurrence_Of (C, Loc), 12657 Right_Opnd => 12658 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 12659 12660 Right_Opnd => 12661 Make_Or_Else (Loc, 12662 Left_Opnd => 12663 Make_Op_Eq (Loc, 12664 Left_Opnd => New_Occurrence_Of (C, Loc), 12665 Right_Opnd => 12666 New_Occurrence_Of (RTE ( 12667 RE_POK_Protected_Procedure), Loc)), 12668 Right_Opnd => 12669 Make_Op_Eq (Loc, 12670 Left_Opnd => New_Occurrence_Of (C, Loc), 12671 Right_Opnd => 12672 New_Occurrence_Of 12673 (RTE (RE_POK_Task_Procedure), Loc)))), 12674 12675 Then_Statements => New_List (E_Call))); 12676 12677 Append_To (Conc_Typ_Stmts, 12678 Make_Implicit_If_Statement (N, 12679 Condition => New_Occurrence_Of (B, Loc), 12680 Then_Statements => N_Stats)); 12681 12682 -- Generate: 12683 -- <dispatching-call>; 12684 -- B := True; 12685 12686 Lim_Typ_Stmts := 12687 New_List (New_Copy_Tree (E_Call), 12688 Make_Assignment_Statement (Loc, 12689 Name => New_Occurrence_Of (B, Loc), 12690 Expression => New_Occurrence_Of (Standard_True, Loc))); 12691 12692 -- Generate: 12693 -- if K = Ada.Tags.TK_Limited_Tagged 12694 -- or else K = Ada.Tags.TK_Tagged 12695 -- then 12696 -- Lim_Typ_Stmts 12697 -- else 12698 -- Conc_Typ_Stmts 12699 -- end if; 12700 12701 Append_To (Stmts, 12702 Make_Implicit_If_Statement (N, 12703 Condition => Build_Dispatching_Tag_Check (K, N), 12704 Then_Statements => Lim_Typ_Stmts, 12705 Else_Statements => Conc_Typ_Stmts)); 12706 12707 -- Generate: 12708 12709 -- if B then 12710 -- <triggering-statements> 12711 -- else 12712 -- <timed-statements> 12713 -- end if; 12714 12715 Append_To (Stmts, 12716 Make_Implicit_If_Statement (N, 12717 Condition => New_Occurrence_Of (B, Loc), 12718 Then_Statements => E_Stats, 12719 Else_Statements => D_Stats)); 12720 12721 else 12722 -- Simple case of a nondispatching trigger. Skip assignments to 12723 -- temporaries created for in-out parameters. 12724 12725 -- This makes unwarranted assumptions about the shape of the expanded 12726 -- tree for the call, and should be cleaned up ??? 12727 12728 Stmt := First (Stmts); 12729 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 12730 Next (Stmt); 12731 end loop; 12732 12733 -- Do the assignment at this stage only because the evaluation 12734 -- of the expression must not occur before (see ACVC C97302A). 12735 12736 Insert_Before (Stmt, 12737 Make_Assignment_Statement (Loc, 12738 Name => New_Occurrence_Of (D, Loc), 12739 Expression => D_Conv)); 12740 12741 Call := Stmt; 12742 Params := Parameter_Associations (Call); 12743 12744 -- For a protected type, we build a Timed_Protected_Entry_Call 12745 12746 if Is_Protected_Type (Etype (Concval)) then 12747 12748 -- Create a new call statement 12749 12750 Param := First (Params); 12751 while Present (Param) 12752 and then not Is_RTE (Etype (Param), RE_Call_Modes) 12753 loop 12754 Next (Param); 12755 end loop; 12756 12757 Dummy := Remove_Next (Next (Param)); 12758 12759 -- Remove garbage is following the Cancel_Param if present 12760 12761 Dummy := Next (Param); 12762 12763 -- Remove the mode of the Protected_Entry_Call call, then remove 12764 -- the Communication_Block of the Protected_Entry_Call call, and 12765 -- finally add Duration and a Delay_Mode parameter 12766 12767 pragma Assert (Present (Param)); 12768 Rewrite (Param, New_Occurrence_Of (D, Loc)); 12769 12770 Rewrite (Dummy, New_Occurrence_Of (M, Loc)); 12771 12772 -- Add a Boolean flag for successful entry call 12773 12774 Append_To (Params, New_Occurrence_Of (B, Loc)); 12775 12776 case Corresponding_Runtime_Package (Etype (Concval)) is 12777 when System_Tasking_Protected_Objects_Entries => 12778 Rewrite (Call, 12779 Make_Procedure_Call_Statement (Loc, 12780 Name => 12781 New_Occurrence_Of 12782 (RTE (RE_Timed_Protected_Entry_Call), Loc), 12783 Parameter_Associations => Params)); 12784 12785 when others => 12786 raise Program_Error; 12787 end case; 12788 12789 -- For the task case, build a Timed_Task_Entry_Call 12790 12791 else 12792 -- Create a new call statement 12793 12794 Append_To (Params, New_Occurrence_Of (D, Loc)); 12795 Append_To (Params, New_Occurrence_Of (M, Loc)); 12796 Append_To (Params, New_Occurrence_Of (B, Loc)); 12797 12798 Rewrite (Call, 12799 Make_Procedure_Call_Statement (Loc, 12800 Name => 12801 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc), 12802 Parameter_Associations => Params)); 12803 end if; 12804 12805 Append_To (Stmts, 12806 Make_Implicit_If_Statement (N, 12807 Condition => New_Occurrence_Of (B, Loc), 12808 Then_Statements => E_Stats, 12809 Else_Statements => D_Stats)); 12810 end if; 12811 12812 Rewrite (N, 12813 Make_Block_Statement (Loc, 12814 Declarations => Decls, 12815 Handled_Statement_Sequence => 12816 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 12817 12818 Analyze (N); 12819 end Expand_N_Timed_Entry_Call; 12820 12821 ---------------------------------------- 12822 -- Expand_Protected_Body_Declarations -- 12823 ---------------------------------------- 12824 12825 procedure Expand_Protected_Body_Declarations 12826 (N : Node_Id; 12827 Spec_Id : Entity_Id) 12828 is 12829 begin 12830 if No_Run_Time_Mode then 12831 Error_Msg_CRT ("protected body", N); 12832 return; 12833 12834 elsif Expander_Active then 12835 12836 -- Associate discriminals with the first subprogram or entry body to 12837 -- be expanded. 12838 12839 if Present (First_Protected_Operation (Declarations (N))) then 12840 Set_Discriminals (Parent (Spec_Id)); 12841 end if; 12842 end if; 12843 end Expand_Protected_Body_Declarations; 12844 12845 ------------------------- 12846 -- External_Subprogram -- 12847 ------------------------- 12848 12849 function External_Subprogram (E : Entity_Id) return Entity_Id is 12850 Subp : constant Entity_Id := Protected_Body_Subprogram (E); 12851 12852 begin 12853 -- The internal and external subprograms follow each other on the entity 12854 -- chain. Note that previously private operations had no separate 12855 -- external subprogram. We now create one in all cases, because a 12856 -- private operation may actually appear in an external call, through 12857 -- a 'Access reference used for a callback. 12858 12859 -- If the operation is a function that returns an anonymous access type, 12860 -- the corresponding itype appears before the operation, and must be 12861 -- skipped. 12862 12863 -- This mechanism is fragile, there should be a real link between the 12864 -- two versions of the operation, but there is no place to put it ??? 12865 12866 if Is_Access_Type (Next_Entity (Subp)) then 12867 return Next_Entity (Next_Entity (Subp)); 12868 else 12869 return Next_Entity (Subp); 12870 end if; 12871 end External_Subprogram; 12872 12873 ------------------------------ 12874 -- Extract_Dispatching_Call -- 12875 ------------------------------ 12876 12877 procedure Extract_Dispatching_Call 12878 (N : Node_Id; 12879 Call_Ent : out Entity_Id; 12880 Object : out Entity_Id; 12881 Actuals : out List_Id; 12882 Formals : out List_Id) 12883 is 12884 Call_Nam : Node_Id; 12885 12886 begin 12887 pragma Assert (Nkind (N) = N_Procedure_Call_Statement); 12888 12889 if Present (Original_Node (N)) then 12890 Call_Nam := Name (Original_Node (N)); 12891 else 12892 Call_Nam := Name (N); 12893 end if; 12894 12895 -- Retrieve the name of the dispatching procedure. It contains the 12896 -- dispatch table slot number. 12897 12898 loop 12899 case Nkind (Call_Nam) is 12900 when N_Identifier => 12901 exit; 12902 12903 when N_Selected_Component => 12904 Call_Nam := Selector_Name (Call_Nam); 12905 12906 when others => 12907 raise Program_Error; 12908 end case; 12909 end loop; 12910 12911 Actuals := Parameter_Associations (N); 12912 Call_Ent := Entity (Call_Nam); 12913 Formals := Parameter_Specifications (Parent (Call_Ent)); 12914 Object := First (Actuals); 12915 12916 if Present (Original_Node (Object)) then 12917 Object := Original_Node (Object); 12918 end if; 12919 12920 -- If the type of the dispatching object is an access type then return 12921 -- an explicit dereference of a copy of the object, and note that this 12922 -- is the controlling actual of the call. 12923 12924 if Is_Access_Type (Etype (Object)) then 12925 Object := 12926 Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object)); 12927 Analyze (Object); 12928 Set_Is_Controlling_Actual (Object); 12929 end if; 12930 end Extract_Dispatching_Call; 12931 12932 ------------------- 12933 -- Extract_Entry -- 12934 ------------------- 12935 12936 procedure Extract_Entry 12937 (N : Node_Id; 12938 Concval : out Node_Id; 12939 Ename : out Node_Id; 12940 Index : out Node_Id) 12941 is 12942 Nam : constant Node_Id := Name (N); 12943 12944 begin 12945 -- For a simple entry, the name is a selected component, with the 12946 -- prefix being the task value, and the selector being the entry. 12947 12948 if Nkind (Nam) = N_Selected_Component then 12949 Concval := Prefix (Nam); 12950 Ename := Selector_Name (Nam); 12951 Index := Empty; 12952 12953 -- For a member of an entry family, the name is an indexed component 12954 -- where the prefix is a selected component, whose prefix in turn is 12955 -- the task value, and whose selector is the entry family. The single 12956 -- expression in the expressions list of the indexed component is the 12957 -- subscript for the family. 12958 12959 else pragma Assert (Nkind (Nam) = N_Indexed_Component); 12960 Concval := Prefix (Prefix (Nam)); 12961 Ename := Selector_Name (Prefix (Nam)); 12962 Index := First (Expressions (Nam)); 12963 end if; 12964 12965 -- Through indirection, the type may actually be a limited view of a 12966 -- concurrent type. When compiling a call, the non-limited view of the 12967 -- type is visible. 12968 12969 if From_Limited_With (Etype (Concval)) then 12970 Set_Etype (Concval, Non_Limited_View (Etype (Concval))); 12971 end if; 12972 end Extract_Entry; 12973 12974 ------------------- 12975 -- Family_Offset -- 12976 ------------------- 12977 12978 function Family_Offset 12979 (Loc : Source_Ptr; 12980 Hi : Node_Id; 12981 Lo : Node_Id; 12982 Ttyp : Entity_Id; 12983 Cap : Boolean) return Node_Id 12984 is 12985 Ityp : Entity_Id; 12986 Real_Hi : Node_Id; 12987 Real_Lo : Node_Id; 12988 12989 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 12990 -- If one of the bounds is a reference to a discriminant, replace with 12991 -- corresponding discriminal of type. Within the body of a task retrieve 12992 -- the renamed discriminant by simple visibility, using its generated 12993 -- name. Within a protected object, find the original discriminant and 12994 -- replace it with the discriminal of the current protected operation. 12995 12996 ------------------------------ 12997 -- Convert_Discriminant_Ref -- 12998 ------------------------------ 12999 13000 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 13001 Loc : constant Source_Ptr := Sloc (Bound); 13002 B : Node_Id; 13003 D : Entity_Id; 13004 13005 begin 13006 if Is_Entity_Name (Bound) 13007 and then Ekind (Entity (Bound)) = E_Discriminant 13008 then 13009 if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then 13010 B := Make_Identifier (Loc, Chars (Entity (Bound))); 13011 Find_Direct_Name (B); 13012 13013 elsif Is_Protected_Type (Ttyp) then 13014 D := First_Discriminant (Ttyp); 13015 while Chars (D) /= Chars (Entity (Bound)) loop 13016 Next_Discriminant (D); 13017 end loop; 13018 13019 B := New_Occurrence_Of (Discriminal (D), Loc); 13020 13021 else 13022 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); 13023 end if; 13024 13025 elsif Nkind (Bound) = N_Attribute_Reference then 13026 return Bound; 13027 13028 else 13029 B := New_Copy_Tree (Bound); 13030 end if; 13031 13032 return 13033 Make_Attribute_Reference (Loc, 13034 Attribute_Name => Name_Pos, 13035 Prefix => New_Occurrence_Of (Etype (Bound), Loc), 13036 Expressions => New_List (B)); 13037 end Convert_Discriminant_Ref; 13038 13039 -- Start of processing for Family_Offset 13040 13041 begin 13042 Real_Hi := Convert_Discriminant_Ref (Hi); 13043 Real_Lo := Convert_Discriminant_Ref (Lo); 13044 13045 if Cap then 13046 if Is_Task_Type (Ttyp) then 13047 Ityp := RTE (RE_Task_Entry_Index); 13048 else 13049 Ityp := RTE (RE_Protected_Entry_Index); 13050 end if; 13051 13052 Real_Hi := 13053 Make_Attribute_Reference (Loc, 13054 Prefix => New_Occurrence_Of (Ityp, Loc), 13055 Attribute_Name => Name_Min, 13056 Expressions => New_List ( 13057 Real_Hi, 13058 Make_Integer_Literal (Loc, Entry_Family_Bound - 1))); 13059 13060 Real_Lo := 13061 Make_Attribute_Reference (Loc, 13062 Prefix => New_Occurrence_Of (Ityp, Loc), 13063 Attribute_Name => Name_Max, 13064 Expressions => New_List ( 13065 Real_Lo, 13066 Make_Integer_Literal (Loc, -Entry_Family_Bound))); 13067 end if; 13068 13069 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo); 13070 end Family_Offset; 13071 13072 ----------------- 13073 -- Family_Size -- 13074 ----------------- 13075 13076 function Family_Size 13077 (Loc : Source_Ptr; 13078 Hi : Node_Id; 13079 Lo : Node_Id; 13080 Ttyp : Entity_Id; 13081 Cap : Boolean) return Node_Id 13082 is 13083 Ityp : Entity_Id; 13084 13085 begin 13086 if Is_Task_Type (Ttyp) then 13087 Ityp := RTE (RE_Task_Entry_Index); 13088 else 13089 Ityp := RTE (RE_Protected_Entry_Index); 13090 end if; 13091 13092 return 13093 Make_Attribute_Reference (Loc, 13094 Prefix => New_Occurrence_Of (Ityp, Loc), 13095 Attribute_Name => Name_Max, 13096 Expressions => New_List ( 13097 Make_Op_Add (Loc, 13098 Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap), 13099 Right_Opnd => Make_Integer_Literal (Loc, 1)), 13100 Make_Integer_Literal (Loc, 0))); 13101 end Family_Size; 13102 13103 ---------------------------- 13104 -- Find_Enclosing_Context -- 13105 ---------------------------- 13106 13107 procedure Find_Enclosing_Context 13108 (N : Node_Id; 13109 Context : out Node_Id; 13110 Context_Id : out Entity_Id; 13111 Context_Decls : out List_Id) 13112 is 13113 begin 13114 -- Traverse the parent chain looking for an enclosing body, block, 13115 -- package or return statement. 13116 13117 Context := Parent (N); 13118 while Present (Context) loop 13119 if Nkind_In (Context, N_Entry_Body, 13120 N_Extended_Return_Statement, 13121 N_Package_Body, 13122 N_Package_Declaration, 13123 N_Subprogram_Body, 13124 N_Task_Body) 13125 then 13126 exit; 13127 13128 -- Do not consider block created to protect a list of statements with 13129 -- an Abort_Defer / Abort_Undefer_Direct pair. 13130 13131 elsif Nkind (Context) = N_Block_Statement 13132 and then not Is_Abort_Block (Context) 13133 then 13134 exit; 13135 end if; 13136 13137 Context := Parent (Context); 13138 end loop; 13139 13140 pragma Assert (Present (Context)); 13141 13142 -- Extract the constituents of the context 13143 13144 if Nkind (Context) = N_Extended_Return_Statement then 13145 Context_Decls := Return_Object_Declarations (Context); 13146 Context_Id := Return_Statement_Entity (Context); 13147 13148 -- Package declarations and bodies use a common library-level activation 13149 -- chain or task master, therefore return the package declaration as the 13150 -- proper carrier for the appropriate flag. 13151 13152 elsif Nkind (Context) = N_Package_Body then 13153 Context_Decls := Declarations (Context); 13154 Context_Id := Corresponding_Spec (Context); 13155 Context := Parent (Context_Id); 13156 13157 if Nkind (Context) = N_Defining_Program_Unit_Name then 13158 Context := Parent (Parent (Context)); 13159 else 13160 Context := Parent (Context); 13161 end if; 13162 13163 elsif Nkind (Context) = N_Package_Declaration then 13164 Context_Decls := Visible_Declarations (Specification (Context)); 13165 Context_Id := Defining_Unit_Name (Specification (Context)); 13166 13167 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13168 Context_Id := Defining_Identifier (Context_Id); 13169 end if; 13170 13171 else 13172 if Nkind (Context) = N_Block_Statement then 13173 Context_Id := Entity (Identifier (Context)); 13174 13175 elsif Nkind (Context) = N_Entry_Body then 13176 Context_Id := Defining_Identifier (Context); 13177 13178 elsif Nkind (Context) = N_Subprogram_Body then 13179 if Present (Corresponding_Spec (Context)) then 13180 Context_Id := Corresponding_Spec (Context); 13181 else 13182 Context_Id := Defining_Unit_Name (Specification (Context)); 13183 13184 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13185 Context_Id := Defining_Identifier (Context_Id); 13186 end if; 13187 end if; 13188 13189 elsif Nkind (Context) = N_Task_Body then 13190 Context_Id := Corresponding_Spec (Context); 13191 13192 else 13193 raise Program_Error; 13194 end if; 13195 13196 Context_Decls := Declarations (Context); 13197 end if; 13198 13199 pragma Assert (Present (Context_Id)); 13200 pragma Assert (Present (Context_Decls)); 13201 end Find_Enclosing_Context; 13202 13203 ----------------------- 13204 -- Find_Master_Scope -- 13205 ----------------------- 13206 13207 function Find_Master_Scope (E : Entity_Id) return Entity_Id is 13208 S : Entity_Id; 13209 13210 begin 13211 -- In Ada 2005, the master is the innermost enclosing scope that is not 13212 -- transient. If the enclosing block is the rewriting of a call or the 13213 -- scope is an extended return statement this is valid master. The 13214 -- master in an extended return is only used within the return, and is 13215 -- subsequently overwritten in Move_Activation_Chain, but it must exist 13216 -- now before that overwriting occurs. 13217 13218 S := Scope (E); 13219 13220 if Ada_Version >= Ada_2005 then 13221 while Is_Internal (S) loop 13222 if Nkind (Parent (S)) = N_Block_Statement 13223 and then 13224 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement 13225 then 13226 exit; 13227 13228 elsif Ekind (S) = E_Return_Statement then 13229 exit; 13230 13231 else 13232 S := Scope (S); 13233 end if; 13234 end loop; 13235 end if; 13236 13237 return S; 13238 end Find_Master_Scope; 13239 13240 ------------------------------- 13241 -- First_Protected_Operation -- 13242 ------------------------------- 13243 13244 function First_Protected_Operation (D : List_Id) return Node_Id is 13245 First_Op : Node_Id; 13246 13247 begin 13248 First_Op := First (D); 13249 while Present (First_Op) 13250 and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body) 13251 loop 13252 Next (First_Op); 13253 end loop; 13254 13255 return First_Op; 13256 end First_Protected_Operation; 13257 13258 --------------------------------------- 13259 -- Install_Private_Data_Declarations -- 13260 --------------------------------------- 13261 13262 procedure Install_Private_Data_Declarations 13263 (Loc : Source_Ptr; 13264 Spec_Id : Entity_Id; 13265 Conc_Typ : Entity_Id; 13266 Body_Nod : Node_Id; 13267 Decls : List_Id; 13268 Barrier : Boolean := False; 13269 Family : Boolean := False) 13270 is 13271 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ); 13272 Decl : Node_Id; 13273 Def : Node_Id; 13274 Insert_Node : Node_Id := Empty; 13275 Obj_Ent : Entity_Id; 13276 13277 procedure Add (Decl : Node_Id); 13278 -- Add a single declaration after Insert_Node. If this is the first 13279 -- addition, Decl is added to the front of Decls and it becomes the 13280 -- insertion node. 13281 13282 function Replace_Bound (Bound : Node_Id) return Node_Id; 13283 -- The bounds of an entry index may depend on discriminants, create a 13284 -- reference to the corresponding prival. Otherwise return a duplicate 13285 -- of the original bound. 13286 13287 --------- 13288 -- Add -- 13289 --------- 13290 13291 procedure Add (Decl : Node_Id) is 13292 begin 13293 if No (Insert_Node) then 13294 Prepend_To (Decls, Decl); 13295 else 13296 Insert_After (Insert_Node, Decl); 13297 end if; 13298 13299 Insert_Node := Decl; 13300 end Add; 13301 13302 -------------------------- 13303 -- Replace_Discriminant -- 13304 -------------------------- 13305 13306 function Replace_Bound (Bound : Node_Id) return Node_Id is 13307 begin 13308 if Nkind (Bound) = N_Identifier 13309 and then Is_Discriminal (Entity (Bound)) 13310 then 13311 return Make_Identifier (Loc, Chars (Entity (Bound))); 13312 else 13313 return Duplicate_Subexpr (Bound); 13314 end if; 13315 end Replace_Bound; 13316 13317 -- Start of processing for Install_Private_Data_Declarations 13318 13319 begin 13320 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote 13321 -- formal parameter _O, _object or _task depending on the context. 13322 13323 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ); 13324 13325 -- Special processing of _O for barrier functions, protected entries 13326 -- and families. 13327 13328 if Barrier 13329 or else 13330 (Is_Protected 13331 and then 13332 (Ekind (Spec_Id) = E_Entry 13333 or else Ekind (Spec_Id) = E_Entry_Family)) 13334 then 13335 declare 13336 Conc_Rec : constant Entity_Id := 13337 Corresponding_Record_Type (Conc_Typ); 13338 Typ_Id : constant Entity_Id := 13339 Make_Defining_Identifier (Loc, 13340 New_External_Name (Chars (Conc_Rec), 'P')); 13341 begin 13342 -- Generate: 13343 -- type prot_typVP is access prot_typV; 13344 13345 Decl := 13346 Make_Full_Type_Declaration (Loc, 13347 Defining_Identifier => Typ_Id, 13348 Type_Definition => 13349 Make_Access_To_Object_Definition (Loc, 13350 Subtype_Indication => 13351 New_Occurrence_Of (Conc_Rec, Loc))); 13352 Add (Decl); 13353 13354 -- Generate: 13355 -- _object : prot_typVP := prot_typV (_O); 13356 13357 Decl := 13358 Make_Object_Declaration (Loc, 13359 Defining_Identifier => 13360 Make_Defining_Identifier (Loc, Name_uObject), 13361 Object_Definition => New_Occurrence_Of (Typ_Id, Loc), 13362 Expression => 13363 Unchecked_Convert_To (Typ_Id, 13364 New_Occurrence_Of (Obj_Ent, Loc))); 13365 Add (Decl); 13366 13367 -- Set the reference to the concurrent object 13368 13369 Obj_Ent := Defining_Identifier (Decl); 13370 end; 13371 end if; 13372 13373 -- Step 2: Create the Protection object and build its declaration for 13374 -- any protected entry (family) of subprogram. Note for the lock-free 13375 -- implementation, the Protection object is not needed anymore. 13376 13377 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then 13378 declare 13379 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); 13380 Prot_Typ : RE_Id; 13381 13382 begin 13383 Set_Protection_Object (Spec_Id, Prot_Ent); 13384 13385 -- Determine the proper protection type 13386 13387 if Has_Attach_Handler (Conc_Typ) 13388 and then not Restricted_Profile 13389 then 13390 Prot_Typ := RE_Static_Interrupt_Protection; 13391 13392 elsif Has_Interrupt_Handler (Conc_Typ) 13393 and then not Restriction_Active (No_Dynamic_Attachment) 13394 then 13395 Prot_Typ := RE_Dynamic_Interrupt_Protection; 13396 13397 else 13398 case Corresponding_Runtime_Package (Conc_Typ) is 13399 when System_Tasking_Protected_Objects_Entries => 13400 Prot_Typ := RE_Protection_Entries; 13401 13402 when System_Tasking_Protected_Objects_Single_Entry => 13403 Prot_Typ := RE_Protection_Entry; 13404 13405 when System_Tasking_Protected_Objects => 13406 Prot_Typ := RE_Protection; 13407 13408 when others => 13409 raise Program_Error; 13410 end case; 13411 end if; 13412 13413 -- Generate: 13414 -- conc_typR : protection_typ renames _object._object; 13415 13416 Decl := 13417 Make_Object_Renaming_Declaration (Loc, 13418 Defining_Identifier => Prot_Ent, 13419 Subtype_Mark => 13420 New_Occurrence_Of (RTE (Prot_Typ), Loc), 13421 Name => 13422 Make_Selected_Component (Loc, 13423 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13424 Selector_Name => Make_Identifier (Loc, Name_uObject))); 13425 Add (Decl); 13426 end; 13427 end if; 13428 13429 -- Step 3: Add discriminant renamings (if any) 13430 13431 if Has_Discriminants (Conc_Typ) then 13432 declare 13433 D : Entity_Id; 13434 13435 begin 13436 D := First_Discriminant (Conc_Typ); 13437 while Present (D) loop 13438 13439 -- Adjust the source location 13440 13441 Set_Sloc (Discriminal (D), Loc); 13442 13443 -- Generate: 13444 -- discr_name : discr_typ renames _object.discr_name; 13445 -- or 13446 -- discr_name : discr_typ renames _task.discr_name; 13447 13448 Decl := 13449 Make_Object_Renaming_Declaration (Loc, 13450 Defining_Identifier => Discriminal (D), 13451 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc), 13452 Name => 13453 Make_Selected_Component (Loc, 13454 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13455 Selector_Name => Make_Identifier (Loc, Chars (D)))); 13456 Add (Decl); 13457 13458 -- Set debug info needed on this renaming declaration even 13459 -- though it does not come from source, so that the debugger 13460 -- will get the right information for these generated names. 13461 13462 Set_Debug_Info_Needed (Discriminal (D)); 13463 13464 Next_Discriminant (D); 13465 end loop; 13466 end; 13467 end if; 13468 13469 -- Step 4: Add private component renamings (if any) 13470 13471 if Is_Protected then 13472 Def := Protected_Definition (Parent (Conc_Typ)); 13473 13474 if Present (Private_Declarations (Def)) then 13475 declare 13476 Comp : Node_Id; 13477 Comp_Id : Entity_Id; 13478 Decl_Id : Entity_Id; 13479 13480 begin 13481 Comp := First (Private_Declarations (Def)); 13482 while Present (Comp) loop 13483 if Nkind (Comp) = N_Component_Declaration then 13484 Comp_Id := Defining_Identifier (Comp); 13485 Decl_Id := 13486 Make_Defining_Identifier (Loc, Chars (Comp_Id)); 13487 13488 -- Minimal decoration 13489 13490 if Ekind (Spec_Id) = E_Function then 13491 Set_Ekind (Decl_Id, E_Constant); 13492 else 13493 Set_Ekind (Decl_Id, E_Variable); 13494 end if; 13495 13496 Set_Prival (Comp_Id, Decl_Id); 13497 Set_Prival_Link (Decl_Id, Comp_Id); 13498 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); 13499 13500 -- Generate: 13501 -- comp_name : comp_typ renames _object.comp_name; 13502 13503 Decl := 13504 Make_Object_Renaming_Declaration (Loc, 13505 Defining_Identifier => Decl_Id, 13506 Subtype_Mark => 13507 New_Occurrence_Of (Etype (Comp_Id), Loc), 13508 Name => 13509 Make_Selected_Component (Loc, 13510 Prefix => 13511 New_Occurrence_Of (Obj_Ent, Loc), 13512 Selector_Name => 13513 Make_Identifier (Loc, Chars (Comp_Id)))); 13514 Add (Decl); 13515 end if; 13516 13517 Next (Comp); 13518 end loop; 13519 end; 13520 end if; 13521 end if; 13522 13523 -- Step 5: Add the declaration of the entry index and the associated 13524 -- type for barrier functions and entry families. 13525 13526 if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then 13527 declare 13528 E : constant Entity_Id := Index_Object (Spec_Id); 13529 Index : constant Entity_Id := 13530 Defining_Identifier 13531 (Entry_Index_Specification 13532 (Entry_Body_Formal_Part (Body_Nod))); 13533 Index_Con : constant Entity_Id := 13534 Make_Defining_Identifier (Loc, Chars (Index)); 13535 High : Node_Id; 13536 Index_Typ : Entity_Id; 13537 Low : Node_Id; 13538 13539 begin 13540 -- Minimal decoration 13541 13542 Set_Ekind (Index_Con, E_Constant); 13543 Set_Entry_Index_Constant (Index, Index_Con); 13544 Set_Discriminal_Link (Index_Con, Index); 13545 13546 -- Retrieve the bounds of the entry family 13547 13548 High := Type_High_Bound (Etype (Index)); 13549 Low := Type_Low_Bound (Etype (Index)); 13550 13551 -- In the simple case the entry family is given by a subtype mark 13552 -- and the index constant has the same type. 13553 13554 if Is_Entity_Name (Original_Node ( 13555 Discrete_Subtype_Definition (Parent (Index)))) 13556 then 13557 Index_Typ := Etype (Index); 13558 13559 -- Otherwise a new subtype declaration is required 13560 13561 else 13562 High := Replace_Bound (High); 13563 Low := Replace_Bound (Low); 13564 13565 Index_Typ := Make_Temporary (Loc, 'J'); 13566 13567 -- Generate: 13568 -- subtype Jnn is <Etype of Index> range Low .. High; 13569 13570 Decl := 13571 Make_Subtype_Declaration (Loc, 13572 Defining_Identifier => Index_Typ, 13573 Subtype_Indication => 13574 Make_Subtype_Indication (Loc, 13575 Subtype_Mark => 13576 New_Occurrence_Of (Base_Type (Etype (Index)), Loc), 13577 Constraint => 13578 Make_Range_Constraint (Loc, 13579 Range_Expression => 13580 Make_Range (Loc, Low, High)))); 13581 Add (Decl); 13582 end if; 13583 13584 Set_Etype (Index_Con, Index_Typ); 13585 13586 -- Create the object which designates the index: 13587 -- J : constant Jnn := 13588 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First)); 13589 -- 13590 -- where Jnn is the subtype created above or the original type of 13591 -- the index, _E is a formal of the protected body subprogram and 13592 -- <index expr> is the index of the first family member. 13593 13594 Decl := 13595 Make_Object_Declaration (Loc, 13596 Defining_Identifier => Index_Con, 13597 Constant_Present => True, 13598 Object_Definition => 13599 New_Occurrence_Of (Index_Typ, Loc), 13600 13601 Expression => 13602 Make_Attribute_Reference (Loc, 13603 Prefix => 13604 New_Occurrence_Of (Index_Typ, Loc), 13605 Attribute_Name => Name_Val, 13606 13607 Expressions => New_List ( 13608 13609 Make_Op_Add (Loc, 13610 Left_Opnd => 13611 Make_Op_Subtract (Loc, 13612 Left_Opnd => New_Occurrence_Of (E, Loc), 13613 Right_Opnd => 13614 Entry_Index_Expression (Loc, 13615 Defining_Identifier (Body_Nod), 13616 Empty, Conc_Typ)), 13617 13618 Right_Opnd => 13619 Make_Attribute_Reference (Loc, 13620 Prefix => 13621 New_Occurrence_Of (Index_Typ, Loc), 13622 Attribute_Name => Name_Pos, 13623 Expressions => New_List ( 13624 Make_Attribute_Reference (Loc, 13625 Prefix => 13626 New_Occurrence_Of (Index_Typ, Loc), 13627 Attribute_Name => Name_First))))))); 13628 Add (Decl); 13629 end; 13630 end if; 13631 end Install_Private_Data_Declarations; 13632 13633 --------------------------------- 13634 -- Is_Potentially_Large_Family -- 13635 --------------------------------- 13636 13637 function Is_Potentially_Large_Family 13638 (Base_Index : Entity_Id; 13639 Conctyp : Entity_Id; 13640 Lo : Node_Id; 13641 Hi : Node_Id) return Boolean 13642 is 13643 begin 13644 return Scope (Base_Index) = Standard_Standard 13645 and then Base_Index = Base_Type (Standard_Integer) 13646 and then Has_Discriminants (Conctyp) 13647 and then 13648 Present (Discriminant_Default_Value (First_Discriminant (Conctyp))) 13649 and then 13650 (Denotes_Discriminant (Lo, True) 13651 or else 13652 Denotes_Discriminant (Hi, True)); 13653 end Is_Potentially_Large_Family; 13654 13655 ------------------------------------- 13656 -- Is_Private_Primitive_Subprogram -- 13657 ------------------------------------- 13658 13659 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is 13660 begin 13661 return 13662 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure) 13663 and then Is_Private_Primitive (Id); 13664 end Is_Private_Primitive_Subprogram; 13665 13666 ------------------ 13667 -- Index_Object -- 13668 ------------------ 13669 13670 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is 13671 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id); 13672 Formal : Entity_Id; 13673 13674 begin 13675 Formal := First_Formal (Bod_Subp); 13676 while Present (Formal) loop 13677 13678 -- Look for formal parameter _E 13679 13680 if Chars (Formal) = Name_uE then 13681 return Formal; 13682 end if; 13683 13684 Next_Formal (Formal); 13685 end loop; 13686 13687 -- A protected body subprogram should always have the parameter in 13688 -- question. 13689 13690 raise Program_Error; 13691 end Index_Object; 13692 13693 -------------------------------- 13694 -- Make_Initialize_Protection -- 13695 -------------------------------- 13696 13697 function Make_Initialize_Protection 13698 (Protect_Rec : Entity_Id) return List_Id 13699 is 13700 Loc : constant Source_Ptr := Sloc (Protect_Rec); 13701 P_Arr : Entity_Id; 13702 Pdec : Node_Id; 13703 Ptyp : constant Node_Id := 13704 Corresponding_Concurrent_Type (Protect_Rec); 13705 Args : List_Id; 13706 L : constant List_Id := New_List; 13707 Has_Entry : constant Boolean := Has_Entries (Ptyp); 13708 Prio_Type : Entity_Id; 13709 Prio_Var : Entity_Id := Empty; 13710 Restricted : constant Boolean := Restricted_Profile; 13711 13712 begin 13713 -- We may need two calls to properly initialize the object, one to 13714 -- Initialize_Protection, and possibly one to Install_Handlers if we 13715 -- have a pragma Attach_Handler. 13716 13717 -- Get protected declaration. In the case of a task type declaration, 13718 -- this is simply the parent of the protected type entity. In the single 13719 -- protected object declaration, this parent will be the implicit type, 13720 -- and we can find the corresponding single protected object declaration 13721 -- by searching forward in the declaration list in the tree. 13722 13723 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes 13724 -- of this type should have been removed during semantic analysis. 13725 13726 Pdec := Parent (Ptyp); 13727 while not Nkind_In (Pdec, N_Protected_Type_Declaration, 13728 N_Single_Protected_Declaration) 13729 loop 13730 Next (Pdec); 13731 end loop; 13732 13733 -- Build the parameter list for the call. Note that _Init is the name 13734 -- of the formal for the object to be initialized, which is the task 13735 -- value record itself. 13736 13737 Args := New_List; 13738 13739 -- For lock-free implementation, skip initializations of the Protection 13740 -- object. 13741 13742 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 13743 13744 -- Object parameter. This is a pointer to the object of type 13745 -- Protection used by the GNARL to control the protected object. 13746 13747 Append_To (Args, 13748 Make_Attribute_Reference (Loc, 13749 Prefix => 13750 Make_Selected_Component (Loc, 13751 Prefix => Make_Identifier (Loc, Name_uInit), 13752 Selector_Name => Make_Identifier (Loc, Name_uObject)), 13753 Attribute_Name => Name_Unchecked_Access)); 13754 13755 -- Priority parameter. Set to Unspecified_Priority unless there is a 13756 -- Priority rep item, in which case we take the value from the pragma 13757 -- or attribute definition clause, or there is an Interrupt_Priority 13758 -- rep item and no Priority rep item, and we set the ceiling to 13759 -- Interrupt_Priority'Last, an implementation-defined value, see 13760 -- (RM D.3(10)). 13761 13762 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then 13763 declare 13764 Prio_Clause : constant Node_Id := 13765 Get_Rep_Item 13766 (Ptyp, Name_Priority, Check_Parents => False); 13767 13768 Prio : Node_Id; 13769 13770 begin 13771 -- Pragma Priority 13772 13773 if Nkind (Prio_Clause) = N_Pragma then 13774 Prio := 13775 Expression 13776 (First (Pragma_Argument_Associations (Prio_Clause))); 13777 13778 -- Get_Rep_Item returns either priority pragma 13779 13780 if Pragma_Name (Prio_Clause) = Name_Priority then 13781 Prio_Type := RTE (RE_Any_Priority); 13782 else 13783 Prio_Type := RTE (RE_Interrupt_Priority); 13784 end if; 13785 13786 -- Attribute definition clause Priority 13787 13788 else 13789 if Chars (Prio_Clause) = Name_Priority then 13790 Prio_Type := RTE (RE_Any_Priority); 13791 else 13792 Prio_Type := RTE (RE_Interrupt_Priority); 13793 end if; 13794 13795 Prio := Expression (Prio_Clause); 13796 end if; 13797 13798 -- Always create a locale variable to capture the priority. 13799 -- The priority is also passed to Install_Restriced_Handlers. 13800 -- Note that it is really necessary to create this variable 13801 -- explicitly. It might be thought that removing side effects 13802 -- would the appropriate approach, but that could generate 13803 -- declarations improperly placed in the enclosing scope. 13804 13805 Prio_Var := Make_Temporary (Loc, 'R', Prio); 13806 Append_To (L, 13807 Make_Object_Declaration (Loc, 13808 Defining_Identifier => Prio_Var, 13809 Object_Definition => New_Occurrence_Of (Prio_Type, Loc), 13810 Expression => Relocate_Node (Prio))); 13811 13812 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 13813 end; 13814 13815 -- When no priority is specified but an xx_Handler pragma is, we 13816 -- default to System.Interrupts.Default_Interrupt_Priority, see 13817 -- D.3(10). 13818 13819 elsif Has_Attach_Handler (Ptyp) 13820 or else Has_Interrupt_Handler (Ptyp) 13821 then 13822 Append_To (Args, 13823 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc)); 13824 13825 -- Normal case, no priority or xx_Handler specified, default priority 13826 13827 else 13828 Append_To (Args, 13829 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 13830 end if; 13831 13832 -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes 13833 13834 if Restricted_Profile and Task_Dispatching_Policy = 'E' then 13835 Deadline_Floor : declare 13836 Item : constant Node_Id := 13837 Get_Rep_Item 13838 (Ptyp, Name_Deadline_Floor, Check_Parents => False); 13839 13840 Deadline : Node_Id; 13841 13842 begin 13843 if Present (Item) then 13844 13845 -- Pragma Deadline_Floor 13846 13847 if Nkind (Item) = N_Pragma then 13848 Deadline := 13849 Expression 13850 (First (Pragma_Argument_Associations (Item))); 13851 13852 -- Attribute definition clause Deadline_Floor 13853 13854 else 13855 pragma Assert 13856 (Nkind (Item) = N_Attribute_Definition_Clause); 13857 13858 Deadline := Expression (Item); 13859 end if; 13860 13861 Append_To (Args, Deadline); 13862 13863 -- Unusual case: default deadline 13864 13865 else 13866 Append_To (Args, 13867 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 13868 end if; 13869 end Deadline_Floor; 13870 end if; 13871 13872 -- Test for Compiler_Info parameter. This parameter allows entry body 13873 -- procedures and barrier functions to be called from the runtime. It 13874 -- is a pointer to the record generated by the compiler to represent 13875 -- the protected object. 13876 13877 -- A protected type without entries that covers an interface and 13878 -- overrides the abstract routines with protected procedures is 13879 -- considered equivalent to a protected type with entries in the 13880 -- context of dispatching select statements. 13881 13882 -- Protected types with interrupt handlers (when not using a 13883 -- restricted profile) are also considered equivalent to protected 13884 -- types with entries. 13885 13886 -- The types which are used (Static_Interrupt_Protection and 13887 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries. 13888 13889 declare 13890 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); 13891 13892 Called_Subp : RE_Id; 13893 13894 begin 13895 case Pkg_Id is 13896 when System_Tasking_Protected_Objects_Entries => 13897 Called_Subp := RE_Initialize_Protection_Entries; 13898 13899 -- Argument Compiler_Info 13900 13901 Append_To (Args, 13902 Make_Attribute_Reference (Loc, 13903 Prefix => Make_Identifier (Loc, Name_uInit), 13904 Attribute_Name => Name_Address)); 13905 13906 when System_Tasking_Protected_Objects_Single_Entry => 13907 Called_Subp := RE_Initialize_Protection_Entry; 13908 13909 -- Argument Compiler_Info 13910 13911 Append_To (Args, 13912 Make_Attribute_Reference (Loc, 13913 Prefix => Make_Identifier (Loc, Name_uInit), 13914 Attribute_Name => Name_Address)); 13915 13916 when System_Tasking_Protected_Objects => 13917 Called_Subp := RE_Initialize_Protection; 13918 13919 when others => 13920 raise Program_Error; 13921 end case; 13922 13923 -- Entry_Queue_Maxes parameter. This is an access to an array of 13924 -- naturals representing the entry queue maximums for each entry 13925 -- in the protected type. Zero represents no max. The access is 13926 -- null if there is no limit for all entries (usual case). 13927 13928 if Has_Entry 13929 and then Pkg_Id = System_Tasking_Protected_Objects_Entries 13930 then 13931 if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then 13932 Append_To (Args, 13933 Make_Attribute_Reference (Loc, 13934 Prefix => 13935 New_Occurrence_Of 13936 (Entry_Max_Queue_Lengths_Array (Ptyp), Loc), 13937 Attribute_Name => Name_Unrestricted_Access)); 13938 else 13939 Append_To (Args, Make_Null (Loc)); 13940 end if; 13941 13942 -- Edge cases exist where entry initialization functions are 13943 -- called, but no entries exist, so null is appended. 13944 13945 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 13946 Append_To (Args, Make_Null (Loc)); 13947 end if; 13948 13949 -- Entry_Bodies parameter. This is a pointer to an array of 13950 -- pointers to the entry body procedures and barrier functions of 13951 -- the object. If the protected type has no entries this object 13952 -- will not exist, in this case, pass a null (it can happen when 13953 -- there are protected interrupt handlers or interfaces). 13954 13955 if Has_Entry then 13956 P_Arr := Entry_Bodies_Array (Ptyp); 13957 13958 -- Argument Entry_Body (for single entry) or Entry_Bodies (for 13959 -- multiple entries). 13960 13961 Append_To (Args, 13962 Make_Attribute_Reference (Loc, 13963 Prefix => New_Occurrence_Of (P_Arr, Loc), 13964 Attribute_Name => Name_Unrestricted_Access)); 13965 13966 if Pkg_Id = System_Tasking_Protected_Objects_Entries then 13967 13968 -- Find index mapping function (clumsy but ok for now) 13969 13970 while Ekind (P_Arr) /= E_Function loop 13971 Next_Entity (P_Arr); 13972 end loop; 13973 13974 Append_To (Args, 13975 Make_Attribute_Reference (Loc, 13976 Prefix => New_Occurrence_Of (P_Arr, Loc), 13977 Attribute_Name => Name_Unrestricted_Access)); 13978 end if; 13979 13980 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then 13981 13982 -- This is the case where we have a protected object with 13983 -- interfaces and no entries, and the single entry restriction 13984 -- is in effect. We pass a null pointer for the entry 13985 -- parameter because there is no actual entry. 13986 13987 Append_To (Args, Make_Null (Loc)); 13988 13989 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 13990 13991 -- This is the case where we have a protected object with no 13992 -- entries and: 13993 -- - either interrupt handlers with non restricted profile, 13994 -- - or interfaces 13995 -- Note that the types which are used for interrupt handlers 13996 -- (Static/Dynamic_Interrupt_Protection) are derived from 13997 -- Protection_Entries. We pass two null pointers because there 13998 -- is no actual entry, and the initialization procedure needs 13999 -- both Entry_Bodies and Find_Body_Index. 14000 14001 Append_To (Args, Make_Null (Loc)); 14002 Append_To (Args, Make_Null (Loc)); 14003 end if; 14004 14005 Append_To (L, 14006 Make_Procedure_Call_Statement (Loc, 14007 Name => 14008 New_Occurrence_Of (RTE (Called_Subp), Loc), 14009 Parameter_Associations => Args)); 14010 end; 14011 end if; 14012 14013 if Has_Attach_Handler (Ptyp) then 14014 14015 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to 14016 -- make the following call: 14017 14018 -- Install_Handlers (_object, 14019 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 14020 14021 -- or, in the case of Ravenscar: 14022 14023 -- Install_Restricted_Handlers 14024 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access))); 14025 14026 declare 14027 Args : constant List_Id := New_List; 14028 Table : constant List_Id := New_List; 14029 Ritem : Node_Id := First_Rep_Item (Ptyp); 14030 14031 begin 14032 -- Build the Priority parameter (only for ravenscar) 14033 14034 if Restricted then 14035 14036 -- Priority comes from a pragma 14037 14038 if Present (Prio_Var) then 14039 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 14040 14041 -- Priority is the default one 14042 14043 else 14044 Append_To (Args, 14045 New_Occurrence_Of 14046 (RTE (RE_Default_Interrupt_Priority), Loc)); 14047 end if; 14048 end if; 14049 14050 -- Build the Attach_Handler table argument 14051 14052 while Present (Ritem) loop 14053 if Nkind (Ritem) = N_Pragma 14054 and then Pragma_Name (Ritem) = Name_Attach_Handler 14055 then 14056 declare 14057 Handler : constant Node_Id := 14058 First (Pragma_Argument_Associations (Ritem)); 14059 14060 Interrupt : constant Node_Id := Next (Handler); 14061 Expr : constant Node_Id := Expression (Interrupt); 14062 14063 begin 14064 Append_To (Table, 14065 Make_Aggregate (Loc, Expressions => New_List ( 14066 Unchecked_Convert_To 14067 (RTE (RE_System_Interrupt_Id), Expr), 14068 Make_Attribute_Reference (Loc, 14069 Prefix => 14070 Make_Selected_Component (Loc, 14071 Prefix => 14072 Make_Identifier (Loc, Name_uInit), 14073 Selector_Name => 14074 Duplicate_Subexpr_No_Checks 14075 (Expression (Handler))), 14076 Attribute_Name => Name_Access)))); 14077 end; 14078 end if; 14079 14080 Next_Rep_Item (Ritem); 14081 end loop; 14082 14083 -- Append the table argument we just built 14084 14085 Append_To (Args, Make_Aggregate (Loc, Table)); 14086 14087 -- Append the Install_Handlers (or Install_Restricted_Handlers) 14088 -- call to the statements. 14089 14090 if Restricted then 14091 -- Call a simplified version of Install_Handlers to be used 14092 -- when the Ravenscar restrictions are in effect 14093 -- (Install_Restricted_Handlers). 14094 14095 Append_To (L, 14096 Make_Procedure_Call_Statement (Loc, 14097 Name => 14098 New_Occurrence_Of 14099 (RTE (RE_Install_Restricted_Handlers), Loc), 14100 Parameter_Associations => Args)); 14101 14102 else 14103 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 14104 14105 -- First, prepends the _object argument 14106 14107 Prepend_To (Args, 14108 Make_Attribute_Reference (Loc, 14109 Prefix => 14110 Make_Selected_Component (Loc, 14111 Prefix => Make_Identifier (Loc, Name_uInit), 14112 Selector_Name => 14113 Make_Identifier (Loc, Name_uObject)), 14114 Attribute_Name => Name_Unchecked_Access)); 14115 end if; 14116 14117 -- Then, insert call to Install_Handlers 14118 14119 Append_To (L, 14120 Make_Procedure_Call_Statement (Loc, 14121 Name => 14122 New_Occurrence_Of (RTE (RE_Install_Handlers), Loc), 14123 Parameter_Associations => Args)); 14124 end if; 14125 end; 14126 end if; 14127 14128 return L; 14129 end Make_Initialize_Protection; 14130 14131 --------------------------- 14132 -- Make_Task_Create_Call -- 14133 --------------------------- 14134 14135 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is 14136 Loc : constant Source_Ptr := Sloc (Task_Rec); 14137 Args : List_Id; 14138 Ecount : Node_Id; 14139 Name : Node_Id; 14140 Tdec : Node_Id; 14141 Tdef : Node_Id; 14142 Tnam : Name_Id; 14143 Ttyp : Node_Id; 14144 14145 begin 14146 Ttyp := Corresponding_Concurrent_Type (Task_Rec); 14147 Tnam := Chars (Ttyp); 14148 14149 -- Get task declaration. In the case of a task type declaration, this is 14150 -- simply the parent of the task type entity. In the single task 14151 -- declaration, this parent will be the implicit type, and we can find 14152 -- the corresponding single task declaration by searching forward in the 14153 -- declaration list in the tree. 14154 14155 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of 14156 -- this type should have been removed during semantic analysis. 14157 14158 Tdec := Parent (Ttyp); 14159 while not Nkind_In (Tdec, N_Task_Type_Declaration, 14160 N_Single_Task_Declaration) 14161 loop 14162 Next (Tdec); 14163 end loop; 14164 14165 -- Now we can find the task definition from this declaration 14166 14167 Tdef := Task_Definition (Tdec); 14168 14169 -- Build the parameter list for the call. Note that _Init is the name 14170 -- of the formal for the object to be initialized, which is the task 14171 -- value record itself. 14172 14173 Args := New_List; 14174 14175 -- Priority parameter. Set to Unspecified_Priority unless there is a 14176 -- Priority rep item, in which case we take the value from the rep item. 14177 -- Not used on Ravenscar_EDF profile. 14178 14179 if not (Restricted_Profile and then Task_Dispatching_Policy = 'E') then 14180 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then 14181 Append_To (Args, 14182 Make_Selected_Component (Loc, 14183 Prefix => Make_Identifier (Loc, Name_uInit), 14184 Selector_Name => Make_Identifier (Loc, Name_uPriority))); 14185 else 14186 Append_To (Args, 14187 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 14188 end if; 14189 end if; 14190 14191 -- Optional Stack parameter 14192 14193 if Restricted_Profile then 14194 14195 -- If the stack has been preallocated by the expander then 14196 -- pass its address. Otherwise, pass a null address. 14197 14198 if Preallocated_Stacks_On_Target then 14199 Append_To (Args, 14200 Make_Attribute_Reference (Loc, 14201 Prefix => 14202 Make_Selected_Component (Loc, 14203 Prefix => Make_Identifier (Loc, Name_uInit), 14204 Selector_Name => Make_Identifier (Loc, Name_uStack)), 14205 Attribute_Name => Name_Address)); 14206 14207 else 14208 Append_To (Args, 14209 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 14210 end if; 14211 end if; 14212 14213 -- Size parameter. If no Storage_Size pragma is present, then 14214 -- the size is taken from the taskZ variable for the type, which 14215 -- is either Unspecified_Size, or has been reset by the use of 14216 -- a Storage_Size attribute definition clause. If a pragma is 14217 -- present, then the size is taken from the _Size field of the 14218 -- task value record, which was set from the pragma value. 14219 14220 if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then 14221 Append_To (Args, 14222 Make_Selected_Component (Loc, 14223 Prefix => Make_Identifier (Loc, Name_uInit), 14224 Selector_Name => Make_Identifier (Loc, Name_uSize))); 14225 14226 else 14227 Append_To (Args, 14228 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc)); 14229 end if; 14230 14231 -- Secondary_Stack parameter used for restricted profiles 14232 14233 if Restricted_Profile then 14234 14235 -- If the secondary stack has been allocated by the expander then 14236 -- pass its access pointer. Otherwise, pass null. 14237 14238 if Create_Secondary_Stack_For_Task (Ttyp) then 14239 Append_To (Args, 14240 Make_Attribute_Reference (Loc, 14241 Prefix => 14242 Make_Selected_Component (Loc, 14243 Prefix => Make_Identifier (Loc, Name_uInit), 14244 Selector_Name => 14245 Make_Identifier (Loc, Name_uSecondary_Stack)), 14246 Attribute_Name => Name_Unrestricted_Access)); 14247 14248 else 14249 Append_To (Args, Make_Null (Loc)); 14250 end if; 14251 end if; 14252 14253 -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there 14254 -- is a Secondary_Stack_Size pragma, in which case take the value from 14255 -- the pragma. If the restriction No_Secondary_Stack is active then a 14256 -- size of 0 is passed regardless to prevent the allocation of the 14257 -- unused stack. 14258 14259 if Restriction_Active (No_Secondary_Stack) then 14260 Append_To (Args, Make_Integer_Literal (Loc, 0)); 14261 14262 elsif Has_Rep_Pragma 14263 (Ttyp, Name_Secondary_Stack_Size, Check_Parents => False) 14264 then 14265 Append_To (Args, 14266 Make_Selected_Component (Loc, 14267 Prefix => Make_Identifier (Loc, Name_uInit), 14268 Selector_Name => 14269 Make_Identifier (Loc, Name_uSecondary_Stack_Size))); 14270 14271 else 14272 Append_To (Args, 14273 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 14274 end if; 14275 14276 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a 14277 -- Task_Info pragma, in which case we take the value from the pragma. 14278 14279 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then 14280 Append_To (Args, 14281 Make_Selected_Component (Loc, 14282 Prefix => Make_Identifier (Loc, Name_uInit), 14283 Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); 14284 14285 else 14286 Append_To (Args, 14287 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc)); 14288 end if; 14289 14290 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item, 14291 -- in which case we take the value from the rep item. The parameter is 14292 -- passed as an Integer because in the case of unspecified CPU the 14293 -- value is not in the range of CPU_Range. 14294 14295 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then 14296 Append_To (Args, 14297 Convert_To (Standard_Integer, 14298 Make_Selected_Component (Loc, 14299 Prefix => Make_Identifier (Loc, Name_uInit), 14300 Selector_Name => Make_Identifier (Loc, Name_uCPU)))); 14301 else 14302 Append_To (Args, 14303 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc)); 14304 end if; 14305 14306 if not Restricted_Profile or else Task_Dispatching_Policy = 'E' then 14307 14308 -- Deadline parameter. If no Relative_Deadline pragma is present, 14309 -- then the deadline is Time_Span_Zero. If a pragma is present, then 14310 -- the deadline is taken from the _Relative_Deadline field of the 14311 -- task value record, which was set from the pragma value. Note that 14312 -- this parameter must not be generated for the restricted profiles 14313 -- since Ravenscar does not allow deadlines. 14314 14315 -- Case where pragma Relative_Deadline applies: use given value 14316 14317 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then 14318 Append_To (Args, 14319 Make_Selected_Component (Loc, 14320 Prefix => Make_Identifier (Loc, Name_uInit), 14321 Selector_Name => 14322 Make_Identifier (Loc, Name_uRelative_Deadline))); 14323 14324 -- No pragma Relative_Deadline apply to the task 14325 14326 else 14327 Append_To (Args, 14328 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 14329 end if; 14330 end if; 14331 14332 if not Restricted_Profile then 14333 14334 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is 14335 -- present, then the dispatching domain is null. If a rep item is 14336 -- present, then the dispatching domain is taken from the 14337 -- _Dispatching_Domain field of the task value record, which was set 14338 -- from the rep item value. 14339 14340 -- Case where Dispatching_Domain rep item applies: use given value 14341 14342 if Has_Rep_Item 14343 (Ttyp, Name_Dispatching_Domain, Check_Parents => False) 14344 then 14345 Append_To (Args, 14346 Make_Selected_Component (Loc, 14347 Prefix => 14348 Make_Identifier (Loc, Name_uInit), 14349 Selector_Name => 14350 Make_Identifier (Loc, Name_uDispatching_Domain))); 14351 14352 -- No pragma or aspect Dispatching_Domain applies to the task 14353 14354 else 14355 Append_To (Args, Make_Null (Loc)); 14356 end if; 14357 14358 -- Number of entries. This is an expression of the form: 14359 14360 -- n + _Init.a'Length + _Init.a'B'Length + ... 14361 14362 -- where a,b... are the entry family names for the task definition 14363 14364 Ecount := 14365 Build_Entry_Count_Expression 14366 (Ttyp, 14367 Component_Items 14368 (Component_List 14369 (Type_Definition 14370 (Parent (Corresponding_Record_Type (Ttyp))))), 14371 Loc); 14372 Append_To (Args, Ecount); 14373 14374 -- Master parameter. This is a reference to the _Master parameter of 14375 -- the initialization procedure, except in the case of the pragma 14376 -- Restrictions (No_Task_Hierarchy) where the value is fixed to 14377 -- System.Tasking.Library_Task_Level. 14378 14379 if Restriction_Active (No_Task_Hierarchy) = False then 14380 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 14381 else 14382 Append_To (Args, 14383 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 14384 end if; 14385 end if; 14386 14387 -- State parameter. This is a pointer to the task body procedure. The 14388 -- required value is obtained by taking 'Unrestricted_Access of the task 14389 -- body procedure and converting it (with an unchecked conversion) to 14390 -- the type required by the task kernel. For further details, see the 14391 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather 14392 -- than 'Address in order to avoid creating trampolines. 14393 14394 declare 14395 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp); 14396 Subp_Ptr_Typ : constant Node_Id := 14397 Create_Itype (E_Access_Subprogram_Type, Tdec); 14398 Ref : constant Node_Id := Make_Itype_Reference (Loc); 14399 14400 begin 14401 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc); 14402 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); 14403 14404 -- Be sure to freeze a reference to the access-to-subprogram type, 14405 -- otherwise gigi will complain that it's in the wrong scope, because 14406 -- it's actually inside the init procedure for the record type that 14407 -- corresponds to the task type. 14408 14409 Set_Itype (Ref, Subp_Ptr_Typ); 14410 Append_Freeze_Action (Task_Rec, Ref); 14411 14412 Append_To (Args, 14413 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), 14414 Make_Qualified_Expression (Loc, 14415 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), 14416 Expression => 14417 Make_Attribute_Reference (Loc, 14418 Prefix => New_Occurrence_Of (Body_Proc, Loc), 14419 Attribute_Name => Name_Unrestricted_Access)))); 14420 end; 14421 14422 -- Discriminants parameter. This is just the address of the task 14423 -- value record itself (which contains the discriminant values 14424 14425 Append_To (Args, 14426 Make_Attribute_Reference (Loc, 14427 Prefix => Make_Identifier (Loc, Name_uInit), 14428 Attribute_Name => Name_Address)); 14429 14430 -- Elaborated parameter. This is an access to the elaboration Boolean 14431 14432 Append_To (Args, 14433 Make_Attribute_Reference (Loc, 14434 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')), 14435 Attribute_Name => Name_Unchecked_Access)); 14436 14437 -- Add Chain parameter (not done for sequential elaboration policy, see 14438 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 14439 14440 if Partition_Elaboration_Policy /= 'S' then 14441 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 14442 end if; 14443 14444 -- Task name parameter. Take this from the _Task_Id parameter to the 14445 -- init call unless there is a Task_Name pragma, in which case we take 14446 -- the value from the pragma. 14447 14448 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then 14449 -- Copy expression in full, because it may be dynamic and have 14450 -- side effects. 14451 14452 Append_To (Args, 14453 New_Copy_Tree 14454 (Expression 14455 (First 14456 (Pragma_Argument_Associations 14457 (Get_Rep_Pragma 14458 (Ttyp, Name_Task_Name, Check_Parents => False)))))); 14459 14460 else 14461 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); 14462 end if; 14463 14464 -- Created_Task parameter. This is the _Task_Id field of the task 14465 -- record value 14466 14467 Append_To (Args, 14468 Make_Selected_Component (Loc, 14469 Prefix => Make_Identifier (Loc, Name_uInit), 14470 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); 14471 14472 declare 14473 Create_RE : RE_Id; 14474 14475 begin 14476 if Restricted_Profile then 14477 if Partition_Elaboration_Policy = 'S' then 14478 Create_RE := RE_Create_Restricted_Task_Sequential; 14479 else 14480 Create_RE := RE_Create_Restricted_Task; 14481 end if; 14482 else 14483 Create_RE := RE_Create_Task; 14484 end if; 14485 14486 Name := New_Occurrence_Of (RTE (Create_RE), Loc); 14487 end; 14488 14489 return 14490 Make_Procedure_Call_Statement (Loc, 14491 Name => Name, 14492 Parameter_Associations => Args); 14493 end Make_Task_Create_Call; 14494 14495 ------------------------------ 14496 -- Next_Protected_Operation -- 14497 ------------------------------ 14498 14499 function Next_Protected_Operation (N : Node_Id) return Node_Id is 14500 Next_Op : Node_Id; 14501 14502 begin 14503 -- Check whether there is a subsequent body for a protected operation 14504 -- in the current protected body. In Ada2012 that includes expression 14505 -- functions that are completions. 14506 14507 Next_Op := Next (N); 14508 while Present (Next_Op) 14509 and then not Nkind_In (Next_Op, 14510 N_Subprogram_Body, N_Entry_Body, N_Expression_Function) 14511 loop 14512 Next (Next_Op); 14513 end loop; 14514 14515 return Next_Op; 14516 end Next_Protected_Operation; 14517 14518 --------------------- 14519 -- Null_Statements -- 14520 --------------------- 14521 14522 function Null_Statements (Stats : List_Id) return Boolean is 14523 Stmt : Node_Id; 14524 14525 begin 14526 Stmt := First (Stats); 14527 while Nkind (Stmt) /= N_Empty 14528 and then (Nkind_In (Stmt, N_Null_Statement, N_Label) 14529 or else 14530 (Nkind (Stmt) = N_Pragma 14531 and then 14532 Nam_In (Pragma_Name_Unmapped (Stmt), 14533 Name_Unreferenced, 14534 Name_Unmodified, 14535 Name_Warnings))) 14536 loop 14537 Next (Stmt); 14538 end loop; 14539 14540 return Nkind (Stmt) = N_Empty; 14541 end Null_Statements; 14542 14543 -------------------------- 14544 -- Parameter_Block_Pack -- 14545 -------------------------- 14546 14547 function Parameter_Block_Pack 14548 (Loc : Source_Ptr; 14549 Blk_Typ : Entity_Id; 14550 Actuals : List_Id; 14551 Formals : List_Id; 14552 Decls : List_Id; 14553 Stmts : List_Id) return Node_Id 14554 is 14555 Actual : Entity_Id; 14556 Expr : Node_Id := Empty; 14557 Formal : Entity_Id; 14558 Has_Param : Boolean := False; 14559 P : Entity_Id; 14560 Params : List_Id; 14561 Temp_Asn : Node_Id; 14562 Temp_Nam : Node_Id; 14563 14564 begin 14565 Actual := First (Actuals); 14566 Formal := Defining_Identifier (First (Formals)); 14567 Params := New_List; 14568 while Present (Actual) loop 14569 if Is_By_Copy_Type (Etype (Actual)) then 14570 -- Generate: 14571 -- Jnn : aliased <formal-type> 14572 14573 Temp_Nam := Make_Temporary (Loc, 'J'); 14574 14575 Append_To (Decls, 14576 Make_Object_Declaration (Loc, 14577 Aliased_Present => True, 14578 Defining_Identifier => Temp_Nam, 14579 Object_Definition => 14580 New_Occurrence_Of (Etype (Formal), Loc))); 14581 14582 -- The object is initialized with an explicit assignment 14583 -- later. Indicate that it does not need an initialization 14584 -- to prevent spurious warnings if the type excludes null. 14585 14586 Set_No_Initialization (Last (Decls)); 14587 14588 if Ekind (Formal) /= E_Out_Parameter then 14589 14590 -- Generate: 14591 -- Jnn := <actual> 14592 14593 Temp_Asn := 14594 New_Occurrence_Of (Temp_Nam, Loc); 14595 14596 Set_Assignment_OK (Temp_Asn); 14597 14598 Append_To (Stmts, 14599 Make_Assignment_Statement (Loc, 14600 Name => Temp_Asn, 14601 Expression => New_Copy_Tree (Actual))); 14602 end if; 14603 14604 -- If the actual is not controlling, generate: 14605 14606 -- Jnn'unchecked_access 14607 14608 -- and add it to aggegate for access to formals. Note that the 14609 -- actual may be by-copy but still be a controlling actual if it 14610 -- is an access to class-wide interface. 14611 14612 if not Is_Controlling_Actual (Actual) then 14613 Append_To (Params, 14614 Make_Attribute_Reference (Loc, 14615 Attribute_Name => Name_Unchecked_Access, 14616 Prefix => New_Occurrence_Of (Temp_Nam, Loc))); 14617 14618 Has_Param := True; 14619 end if; 14620 14621 -- The controlling parameter is omitted 14622 14623 else 14624 if not Is_Controlling_Actual (Actual) then 14625 Append_To (Params, 14626 Make_Reference (Loc, New_Copy_Tree (Actual))); 14627 14628 Has_Param := True; 14629 end if; 14630 end if; 14631 14632 Next_Actual (Actual); 14633 Next_Formal_With_Extras (Formal); 14634 end loop; 14635 14636 if Has_Param then 14637 Expr := Make_Aggregate (Loc, Params); 14638 end if; 14639 14640 -- Generate: 14641 -- P : Ann := ( 14642 -- J1'unchecked_access; 14643 -- <actual2>'reference; 14644 -- ...); 14645 14646 P := Make_Temporary (Loc, 'P'); 14647 14648 Append_To (Decls, 14649 Make_Object_Declaration (Loc, 14650 Defining_Identifier => P, 14651 Object_Definition => New_Occurrence_Of (Blk_Typ, Loc), 14652 Expression => Expr)); 14653 14654 return P; 14655 end Parameter_Block_Pack; 14656 14657 ---------------------------- 14658 -- Parameter_Block_Unpack -- 14659 ---------------------------- 14660 14661 function Parameter_Block_Unpack 14662 (Loc : Source_Ptr; 14663 P : Entity_Id; 14664 Actuals : List_Id; 14665 Formals : List_Id) return List_Id 14666 is 14667 Actual : Entity_Id; 14668 Asnmt : Node_Id; 14669 Formal : Entity_Id; 14670 Has_Asnmt : Boolean := False; 14671 Result : constant List_Id := New_List; 14672 14673 begin 14674 Actual := First (Actuals); 14675 Formal := Defining_Identifier (First (Formals)); 14676 while Present (Actual) loop 14677 if Is_By_Copy_Type (Etype (Actual)) 14678 and then Ekind (Formal) /= E_In_Parameter 14679 then 14680 -- Generate: 14681 -- <actual> := P.<formal>; 14682 14683 Asnmt := 14684 Make_Assignment_Statement (Loc, 14685 Name => 14686 New_Copy (Actual), 14687 Expression => 14688 Make_Explicit_Dereference (Loc, 14689 Make_Selected_Component (Loc, 14690 Prefix => 14691 New_Occurrence_Of (P, Loc), 14692 Selector_Name => 14693 Make_Identifier (Loc, Chars (Formal))))); 14694 14695 Set_Assignment_OK (Name (Asnmt)); 14696 Append_To (Result, Asnmt); 14697 14698 Has_Asnmt := True; 14699 end if; 14700 14701 Next_Actual (Actual); 14702 Next_Formal_With_Extras (Formal); 14703 end loop; 14704 14705 if Has_Asnmt then 14706 return Result; 14707 else 14708 return New_List (Make_Null_Statement (Loc)); 14709 end if; 14710 end Parameter_Block_Unpack; 14711 14712 ---------------------- 14713 -- Set_Discriminals -- 14714 ---------------------- 14715 14716 procedure Set_Discriminals (Dec : Node_Id) is 14717 D : Entity_Id; 14718 Pdef : Entity_Id; 14719 D_Minal : Entity_Id; 14720 14721 begin 14722 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); 14723 Pdef := Defining_Identifier (Dec); 14724 14725 if Has_Discriminants (Pdef) then 14726 D := First_Discriminant (Pdef); 14727 while Present (D) loop 14728 D_Minal := 14729 Make_Defining_Identifier (Sloc (D), 14730 Chars => New_External_Name (Chars (D), 'D')); 14731 14732 Set_Ekind (D_Minal, E_Constant); 14733 Set_Etype (D_Minal, Etype (D)); 14734 Set_Scope (D_Minal, Pdef); 14735 Set_Discriminal (D, D_Minal); 14736 Set_Discriminal_Link (D_Minal, D); 14737 14738 Next_Discriminant (D); 14739 end loop; 14740 end if; 14741 end Set_Discriminals; 14742 14743 ----------------------- 14744 -- Trivial_Accept_OK -- 14745 ----------------------- 14746 14747 function Trivial_Accept_OK return Boolean is 14748 begin 14749 case Opt.Task_Dispatching_Policy is 14750 14751 -- If we have the default task dispatching policy in effect, we can 14752 -- definitely do the optimization (one way of looking at this is to 14753 -- think of the formal definition of the default policy being allowed 14754 -- to run any task it likes after a rendezvous, so even if notionally 14755 -- a full rescheduling occurs, we can say that our dispatching policy 14756 -- (i.e. the default dispatching policy) reorders the queue to be the 14757 -- same as just before the call. 14758 14759 when ' ' => 14760 return True; 14761 14762 -- FIFO_Within_Priorities certainly does not permit this 14763 -- optimization since the Rendezvous is a scheduling action that may 14764 -- require some other task to be run. 14765 14766 when 'F' => 14767 return False; 14768 14769 -- For now, disallow the optimization for all other policies. This 14770 -- may be over-conservative, but it is certainly not incorrect. 14771 14772 when others => 14773 return False; 14774 end case; 14775 end Trivial_Accept_OK; 14776 14777end Exp_Ch9; 14778