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-2020, 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 Aspects; use Aspects; 28with Checks; use Checks; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Ch3; use Exp_Ch3; 33with Exp_Ch6; use Exp_Ch6; 34with Exp_Ch11; use Exp_Ch11; 35with Exp_Dbug; use Exp_Dbug; 36with Exp_Sel; use Exp_Sel; 37with Exp_Smem; use Exp_Smem; 38with Exp_Tss; use Exp_Tss; 39with Exp_Util; use Exp_Util; 40with Freeze; use Freeze; 41with Hostparm; 42with Itypes; use Itypes; 43with Namet; use Namet; 44with Nlists; use Nlists; 45with Nmake; use Nmake; 46with Opt; use Opt; 47with Restrict; use Restrict; 48with Rident; use Rident; 49with Rtsfind; use Rtsfind; 50with Sem; use Sem; 51with Sem_Aux; use Sem_Aux; 52with Sem_Ch5; use Sem_Ch5; 53with Sem_Ch6; use Sem_Ch6; 54with Sem_Ch8; use Sem_Ch8; 55with Sem_Ch9; use Sem_Ch9; 56with Sem_Ch11; use Sem_Ch11; 57with Sem_Ch13; use Sem_Ch13; 58with Sem_Elab; use Sem_Elab; 59with Sem_Eval; use Sem_Eval; 60with Sem_Res; use Sem_Res; 61with Sem_Util; use Sem_Util; 62with Sinfo; use Sinfo; 63with Snames; use Snames; 64with Stand; use Stand; 65with Targparm; use Targparm; 66with Tbuild; use Tbuild; 67with Uintp; use Uintp; 68with Validsw; use Validsw; 69 70package body Exp_Ch9 is 71 72 -- The following constant establishes the upper bound for the index of 73 -- an entry family. It is used to limit the allocated size of protected 74 -- types with defaulted discriminant of an integer type, when the bound 75 -- of some entry family depends on a discriminant. The limitation to entry 76 -- families of 128K should be reasonable in all cases, and is a documented 77 -- implementation restriction. 78 79 Entry_Family_Bound : constant Pos := 2**16; 80 81 ----------------------- 82 -- Local Subprograms -- 83 ----------------------- 84 85 function Actual_Index_Expression 86 (Sloc : Source_Ptr; 87 Ent : Entity_Id; 88 Index : Node_Id; 89 Tsk : Entity_Id) return Node_Id; 90 -- Compute the index position for an entry call. Tsk is the target task. If 91 -- the bounds of some entry family depend on discriminants, the expression 92 -- computed by this function uses the discriminants of the target task. 93 94 procedure Add_Object_Pointer 95 (Loc : Source_Ptr; 96 Conc_Typ : Entity_Id; 97 Decls : List_Id); 98 -- Prepend an object pointer declaration to the declaration list Decls. 99 -- This object pointer is initialized to a type conversion of the System. 100 -- Address pointer passed to entry barrier functions and entry body 101 -- procedures. 102 103 procedure Add_Formal_Renamings 104 (Spec : Node_Id; 105 Decls : List_Id; 106 Ent : Entity_Id; 107 Loc : Source_Ptr); 108 -- Create renaming declarations for the formals, inside the procedure that 109 -- implements an entry body. The renamings make the original names of the 110 -- formals accessible to gdb, and serve no other purpose. 111 -- Spec is the specification of the procedure being built. 112 -- Decls is the list of declarations to be enhanced. 113 -- Ent is the entity for the original entry body. 114 115 function Build_Accept_Body (Astat : Node_Id) return Node_Id; 116 -- Transform accept statement into a block with added exception handler. 117 -- Used both for simple accept statements and for accept alternatives in 118 -- select statements. Astat is the accept statement. 119 120 function Build_Barrier_Function 121 (N : Node_Id; 122 Ent : Entity_Id; 123 Pid : Node_Id) return Node_Id; 124 -- Build the function body returning the value of the barrier expression 125 -- for the specified entry body. 126 127 function Build_Barrier_Function_Specification 128 (Loc : Source_Ptr; 129 Def_Id : Entity_Id) return Node_Id; 130 -- Build a specification for a function implementing the protected entry 131 -- barrier of the specified entry body. 132 133 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id); 134 -- Build the body of a wrapper procedure for an entry or entry family that 135 -- has contract cases, preconditions, or postconditions. The body gathers 136 -- the executable contract items and expands them in the usual way, and 137 -- performs the entry call itself. This way preconditions are evaluated 138 -- before the call is queued. E is the entry in question, and Decl is the 139 -- enclosing synchronized type declaration at whose freeze point the 140 -- generated body is analyzed. 141 142 function Build_Corresponding_Record 143 (N : Node_Id; 144 Ctyp : Node_Id; 145 Loc : Source_Ptr) return Node_Id; 146 -- Common to tasks and protected types. Copy discriminant specifications, 147 -- build record declaration. N is the type declaration, Ctyp is the 148 -- concurrent entity (task type or protected type). 149 150 function Build_Dispatching_Tag_Check 151 (K : Entity_Id; 152 N : Node_Id) return Node_Id; 153 -- Utility to create the tree to check whether the dispatching call in 154 -- a timed entry call, a conditional entry call, or an asynchronous 155 -- transfer of control is a call to a primitive of a non-synchronized type. 156 -- K is the temporary that holds the tagged kind of the target object, and 157 -- N is the enclosing construct. 158 159 function Build_Entry_Count_Expression 160 (Concurrent_Type : Node_Id; 161 Component_List : List_Id; 162 Loc : Source_Ptr) return Node_Id; 163 -- Compute number of entries for concurrent object. This is a count of 164 -- simple entries, followed by an expression that computes the length 165 -- of the range of each entry family. A single array with that size is 166 -- allocated for each concurrent object of the type. 167 168 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; 169 -- Build the function that translates the entry index in the call 170 -- (which depends on the size of entry families) into an index into the 171 -- Entry_Bodies_Array, to determine the body and barrier function used 172 -- in a protected entry call. A pointer to this function appears in every 173 -- protected object. 174 175 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id; 176 -- Build subprogram declaration for previous one 177 178 function Build_Lock_Free_Protected_Subprogram_Body 179 (N : Node_Id; 180 Prot_Typ : Node_Id; 181 Unprot_Spec : Node_Id) return Node_Id; 182 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is 183 -- the subprogram specification of the unprotected version of N. Transform 184 -- N such that it invokes the unprotected version of the body. 185 186 function Build_Lock_Free_Unprotected_Subprogram_Body 187 (N : Node_Id; 188 Prot_Typ : Node_Id) return Node_Id; 189 -- N denotes a subprogram body of protected type Prot_Typ. Build a version 190 -- of N where the original statements of N are synchronized through atomic 191 -- actions such as compare and exchange. Prior to invoking this routine, it 192 -- has been established that N can be implemented in a lock-free fashion. 193 194 function Build_Parameter_Block 195 (Loc : Source_Ptr; 196 Actuals : List_Id; 197 Formals : List_Id; 198 Decls : List_Id) return Entity_Id; 199 -- Generate an access type for each actual parameter in the list Actuals. 200 -- Create an encapsulating record that contains all the actuals and return 201 -- its type. Generate: 202 -- type Ann1 is access all <actual1-type> 203 -- ... 204 -- type AnnN is access all <actualN-type> 205 -- type Pnn is record 206 -- <formal1> : Ann1; 207 -- ... 208 -- <formalN> : AnnN; 209 -- end record; 210 211 function Build_Protected_Entry 212 (N : Node_Id; 213 Ent : Entity_Id; 214 Pid : Node_Id) return Node_Id; 215 -- Build the procedure implementing the statement sequence of the specified 216 -- entry body. 217 218 function Build_Protected_Entry_Specification 219 (Loc : Source_Ptr; 220 Def_Id : Entity_Id; 221 Ent_Id : Entity_Id) return Node_Id; 222 -- Build a specification for the procedure implementing the statements of 223 -- the specified entry body. Add attributes associating it with the entry 224 -- defining identifier Ent_Id. 225 226 function Build_Protected_Spec 227 (N : Node_Id; 228 Obj_Type : Entity_Id; 229 Ident : Entity_Id; 230 Unprotected : Boolean := False) return List_Id; 231 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_ 232 -- Subprogram_Type. Builds signature of protected subprogram, adding the 233 -- formal that corresponds to the object itself. For an access to protected 234 -- subprogram, there is no object type to specify, so the parameter has 235 -- type Address and mode In. An indirect call through such a pointer will 236 -- convert the address to a reference to the actual object. The object is 237 -- a limited record and therefore a by_reference type. 238 239 function Build_Protected_Subprogram_Body 240 (N : Node_Id; 241 Pid : Node_Id; 242 N_Op_Spec : Node_Id) return Node_Id; 243 -- This function is used to construct the protected version of a protected 244 -- subprogram. Its statement sequence first defers abort, then locks the 245 -- associated protected object, and then enters a block that contains a 246 -- call to the unprotected version of the subprogram (for details, see 247 -- Build_Unprotected_Subprogram_Body). This block statement requires a 248 -- cleanup handler that unlocks the object in all cases. For details, 249 -- see Exp_Ch7.Expand_Cleanup_Actions. 250 251 function Build_Renamed_Formal_Declaration 252 (New_F : Entity_Id; 253 Formal : Entity_Id; 254 Comp : Entity_Id; 255 Renamed_Formal : Node_Id) return Node_Id; 256 -- Create a renaming declaration for a formal, within a protected entry 257 -- body or an accept body. The renamed object is a component of the 258 -- parameter block that is a parameter in the entry call. 259 -- 260 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming 261 -- does not dereference the corresponding component to prevent an illegal 262 -- use of the incomplete type (AI05-0151). 263 264 function Build_Selected_Name 265 (Prefix : Entity_Id; 266 Selector : Entity_Id; 267 Append_Char : Character := ' ') return Name_Id; 268 -- Build a name in the form of Prefix__Selector, with an optional character 269 -- appended. This is used for internal subprograms generated for operations 270 -- of protected types, including barrier functions. For the subprograms 271 -- generated for entry bodies and entry barriers, the generated name 272 -- includes a sequence number that makes names unique in the presence of 273 -- entry overloading. This is necessary because entry body procedures and 274 -- barrier functions all have the same signature. 275 276 procedure Build_Simple_Entry_Call 277 (N : Node_Id; 278 Concval : Node_Id; 279 Ename : Node_Id; 280 Index : Node_Id); 281 -- Some comments here would be useful ??? 282 283 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id; 284 -- This routine constructs a specification for the procedure that we will 285 -- build for the task body for task type T. The spec has the form: 286 -- 287 -- procedure tnameB (_Task : access tnameV); 288 -- 289 -- where name is the character name taken from the task type entity that 290 -- is passed as the argument to the procedure, and tnameV is the task 291 -- value type that is associated with the task type. 292 293 function Build_Unprotected_Subprogram_Body 294 (N : Node_Id; 295 Pid : Node_Id) return Node_Id; 296 -- This routine constructs the unprotected version of a protected 297 -- subprogram body, which contains all of the code in the original, 298 -- unexpanded body. This is the version of the protected subprogram that is 299 -- called from all protected operations on the same object, including the 300 -- protected version of the same subprogram. 301 302 procedure Build_Wrapper_Bodies 303 (Loc : Source_Ptr; 304 Typ : Entity_Id; 305 N : Node_Id); 306 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding 307 -- record of a concurrent type. N is the insertion node where all bodies 308 -- will be placed. This routine builds the bodies of the subprograms which 309 -- serve as an indirection mechanism to overriding primitives of concurrent 310 -- types, entries and protected procedures. Any new body is analyzed. 311 312 procedure Build_Wrapper_Specs 313 (Loc : Source_Ptr; 314 Typ : Entity_Id; 315 N : in out Node_Id); 316 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding 317 -- record of a concurrent type. N is the insertion node where all specs 318 -- will be placed. This routine builds the specs of the subprograms which 319 -- serve as an indirection mechanism to overriding primitives of concurrent 320 -- types, entries and protected procedures. Any new spec is analyzed. 321 322 procedure Collect_Entry_Families 323 (Loc : Source_Ptr; 324 Cdecls : List_Id; 325 Current_Node : in out Node_Id; 326 Conctyp : Entity_Id); 327 -- For each entry family in a concurrent type, create an anonymous array 328 -- type of the right size, and add a component to the corresponding_record. 329 330 function Concurrent_Object 331 (Spec_Id : Entity_Id; 332 Conc_Typ : Entity_Id) return Entity_Id; 333 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return 334 -- the entity associated with the concurrent object in the Protected_Body_ 335 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity 336 -- denotes formal parameter _O, _object or _task. 337 338 function Copy_Result_Type (Res : Node_Id) return Node_Id; 339 -- Copy the result type of a function specification, when building the 340 -- internal operation corresponding to a protected function, or when 341 -- expanding an access to protected function. If the result is an anonymous 342 -- access to subprogram itself, we need to create a new signature with the 343 -- same parameter names and the same resolved types, but with new entities 344 -- for the formals. 345 346 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean; 347 -- Return whether a secondary stack for the task T should be created by the 348 -- expander. The secondary stack for a task will be created by the expander 349 -- if the size of the stack has been specified by the Secondary_Stack_Size 350 -- representation aspect and either the No_Implicit_Heap_Allocations or 351 -- No_Implicit_Task_Allocations restrictions are in effect and the 352 -- No_Secondary_Stack restriction is not. 353 354 procedure Debug_Private_Data_Declarations (Decls : List_Id); 355 -- Decls is a list which may contain the declarations created by Install_ 356 -- Private_Data_Declarations. All generated entities are marked as needing 357 -- debug info and debug nodes are manually generation where necessary. This 358 -- step of the expansion must to be done after private data has been moved 359 -- to its final resting scope to ensure proper visibility of debug objects. 360 361 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id); 362 -- If control flow optimizations are suppressed, and Alt is an accept, 363 -- delay, or entry call alternative with no trailing statements, insert 364 -- a null trailing statement with the given Loc (which is the sloc of 365 -- the accept, delay, or entry call statement). There might not be any 366 -- generated code for the accept, delay, or entry call itself (the effect 367 -- of these statements is part of the general processing done for the 368 -- enclosing selective accept, timed entry call, or asynchronous select), 369 -- and the null statement is there to carry the sloc of that statement to 370 -- the back-end for trace-based coverage analysis purposes. 371 372 procedure Extract_Dispatching_Call 373 (N : Node_Id; 374 Call_Ent : out Entity_Id; 375 Object : out Entity_Id; 376 Actuals : out List_Id; 377 Formals : out List_Id); 378 -- Given a dispatching call, extract the entity of the name of the call, 379 -- its actual dispatching object, its actual parameters and the formal 380 -- parameters of the overridden interface-level version. If the type of 381 -- the dispatching object is an access type then an explicit dereference 382 -- is returned in Object. 383 384 procedure Extract_Entry 385 (N : Node_Id; 386 Concval : out Node_Id; 387 Ename : out Node_Id; 388 Index : out Node_Id); 389 -- Given an entry call, returns the associated concurrent object, the entry 390 -- name, and the entry family index. 391 392 function Family_Offset 393 (Loc : Source_Ptr; 394 Hi : Node_Id; 395 Lo : Node_Id; 396 Ttyp : Entity_Id; 397 Cap : Boolean) return Node_Id; 398 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an 399 -- accept statement, or the upper bound in the discrete subtype of an entry 400 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent 401 -- type of the entry. If Cap is true, the result is capped according to 402 -- Entry_Family_Bound. 403 404 function Family_Size 405 (Loc : Source_Ptr; 406 Hi : Node_Id; 407 Lo : Node_Id; 408 Ttyp : Entity_Id; 409 Cap : Boolean) return Node_Id; 410 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a 411 -- family, and handle properly the superflat case. This is equivalent to 412 -- the use of 'Length on the index type, but must use Family_Offset to 413 -- handle properly the case of bounds that depend on discriminants. If 414 -- Cap is true, the result is capped according to Entry_Family_Bound. 415 416 procedure Find_Enclosing_Context 417 (N : Node_Id; 418 Context : out Node_Id; 419 Context_Id : out Entity_Id; 420 Context_Decls : out List_Id); 421 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and 422 -- Build_Master_Entity. Given an arbitrary node in the tree, find the 423 -- nearest enclosing body, block, package, or return statement and return 424 -- its constituents. Context is the enclosing construct, Context_Id is 425 -- the scope of Context_Id and Context_Decls is the declarative list of 426 -- Context. 427 428 function Index_Object (Spec_Id : Entity_Id) return Entity_Id; 429 -- Given a subprogram identifier, return the entity which is associated 430 -- with the protection entry index in the Protected_Body_Subprogram or 431 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal 432 -- parameter _E. 433 434 function Is_Potentially_Large_Family 435 (Base_Index : Entity_Id; 436 Conctyp : Entity_Id; 437 Lo : Node_Id; 438 Hi : Node_Id) return Boolean; 439 -- Determine whether an entry family is potentially large because one of 440 -- its bounds denotes a discrminant. 441 442 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean; 443 -- Determine whether Id is a function or a procedure and is marked as a 444 -- private primitive. 445 446 function Null_Statements (Stats : List_Id) return Boolean; 447 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. 448 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well 449 -- to still count as null. Returns True for a null sequence. The argument 450 -- is the list of statements from the DO-END sequence. 451 452 function Parameter_Block_Pack 453 (Loc : Source_Ptr; 454 Blk_Typ : Entity_Id; 455 Actuals : List_Id; 456 Formals : List_Id; 457 Decls : List_Id; 458 Stmts : List_Id) return Entity_Id; 459 -- Set the components of the generated parameter block with the values 460 -- of the actual parameters. Generate aliased temporaries to capture the 461 -- values for types that are passed by copy. Otherwise generate a reference 462 -- to the actual's value. Return the address of the aggregate block. 463 -- Generate: 464 -- Jnn1 : alias <formal-type1>; 465 -- Jnn1 := <actual1>; 466 -- ... 467 -- P : Blk_Typ := ( 468 -- Jnn1'unchecked_access; 469 -- <actual2>'reference; 470 -- ...); 471 472 function Parameter_Block_Unpack 473 (Loc : Source_Ptr; 474 P : Entity_Id; 475 Actuals : List_Id; 476 Formals : List_Id) return List_Id; 477 -- Retrieve the values of the components from the parameter block and 478 -- assign then to the original actual parameters. Generate: 479 -- <actual1> := P.<formal1>; 480 -- ... 481 -- <actualN> := P.<formalN>; 482 483 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id); 484 -- Reset the scope of declarations and blocks at the top level of Bod to 485 -- be E. Bod is either a block or a subprogram body. Used after expanding 486 -- various kinds of entry bodies into their corresponding constructs. This 487 -- is needed during unnesting to determine whether a body generated for an 488 -- entry or an accept alternative includes uplevel references. 489 490 function Trivial_Accept_OK return Boolean; 491 -- If there is no DO-END block for an accept, or if the DO-END block has 492 -- only null statements, then it is possible to do the Rendezvous with much 493 -- less overhead using the Accept_Trivial routine in the run-time library. 494 -- However, this is not always a valid optimization. Whether it is valid or 495 -- not depends on the Task_Dispatching_Policy. The issue is whether a full 496 -- rescheduling action is required or not. In FIFO_Within_Priorities, such 497 -- a rescheduling is required, so this optimization is not allowed. This 498 -- function returns True if the optimization is permitted. 499 500 ----------------------------- 501 -- Actual_Index_Expression -- 502 ----------------------------- 503 504 function Actual_Index_Expression 505 (Sloc : Source_Ptr; 506 Ent : Entity_Id; 507 Index : Node_Id; 508 Tsk : Entity_Id) return Node_Id 509 is 510 Ttyp : constant Entity_Id := Etype (Tsk); 511 Expr : Node_Id; 512 Num : Node_Id; 513 Lo : Node_Id; 514 Hi : Node_Id; 515 Prev : Entity_Id; 516 S : Node_Id; 517 518 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id; 519 -- Compute difference between bounds of entry family 520 521 -------------------------- 522 -- Actual_Family_Offset -- 523 -------------------------- 524 525 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is 526 527 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; 528 -- Replace a reference to a discriminant with a selected component 529 -- denoting the discriminant of the target task. 530 531 ----------------------------- 532 -- Actual_Discriminant_Ref -- 533 ----------------------------- 534 535 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is 536 Typ : constant Entity_Id := Etype (Bound); 537 B : Node_Id; 538 539 begin 540 if not Is_Entity_Name (Bound) 541 or else Ekind (Entity (Bound)) /= E_Discriminant 542 then 543 if Nkind (Bound) = N_Attribute_Reference then 544 return Bound; 545 else 546 B := New_Copy_Tree (Bound); 547 end if; 548 549 else 550 B := 551 Make_Selected_Component (Sloc, 552 Prefix => New_Copy_Tree (Tsk), 553 Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc)); 554 555 Analyze_And_Resolve (B, Typ); 556 end if; 557 558 return 559 Make_Attribute_Reference (Sloc, 560 Attribute_Name => Name_Pos, 561 Prefix => New_Occurrence_Of (Etype (Bound), Sloc), 562 Expressions => New_List (B)); 563 end Actual_Discriminant_Ref; 564 565 -- Start of processing for Actual_Family_Offset 566 567 begin 568 return 569 Make_Op_Subtract (Sloc, 570 Left_Opnd => Actual_Discriminant_Ref (Hi), 571 Right_Opnd => Actual_Discriminant_Ref (Lo)); 572 end Actual_Family_Offset; 573 574 -- Start of processing for Actual_Index_Expression 575 576 begin 577 -- The queues of entries and entry families appear in textual order in 578 -- the associated record. The entry index is computed as the sum of the 579 -- number of queues for all entries that precede the designated one, to 580 -- which is added the index expression, if this expression denotes a 581 -- member of a family. 582 583 -- The following is a place holder for the count of simple entries 584 585 Num := Make_Integer_Literal (Sloc, 1); 586 587 -- We construct an expression which is a series of addition operations. 588 -- See comments in Entry_Index_Expression, which is identical in 589 -- structure. 590 591 if Present (Index) then 592 S := Entry_Index_Type (Ent); 593 594 -- First make sure the index is in range if requested. The index type 595 -- has been directly set on the prefix, see Resolve_Entry. 596 597 if Do_Range_Check (Index) then 598 Generate_Range_Check 599 (Index, Etype (Prefix (Parent (Index))), CE_Range_Check_Failed); 600 end if; 601 602 Expr := 603 Make_Op_Add (Sloc, 604 Left_Opnd => Num, 605 Right_Opnd => 606 Actual_Family_Offset ( 607 Make_Attribute_Reference (Sloc, 608 Attribute_Name => Name_Pos, 609 Prefix => New_Occurrence_Of (Base_Type (S), Sloc), 610 Expressions => New_List (Relocate_Node (Index))), 611 Type_Low_Bound (S))); 612 else 613 Expr := Num; 614 end if; 615 616 -- Now add lengths of preceding entries and entry families 617 618 Prev := First_Entity (Ttyp); 619 while Chars (Prev) /= Chars (Ent) 620 or else (Ekind (Prev) /= Ekind (Ent)) 621 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 622 loop 623 if Ekind (Prev) = E_Entry then 624 Set_Intval (Num, Intval (Num) + 1); 625 626 elsif Ekind (Prev) = E_Entry_Family then 627 S := Entry_Index_Type (Prev); 628 629 -- The need for the following full view retrieval stems from this 630 -- complex case of nested generics and tasking: 631 632 -- generic 633 -- type Formal_Index is range <>; 634 -- ... 635 -- package Outer is 636 -- type Index is private; 637 -- generic 638 -- ... 639 -- package Inner is 640 -- procedure P; 641 -- end Inner; 642 -- private 643 -- type Index is new Formal_Index range 1 .. 10; 644 -- end Outer; 645 646 -- package body Outer is 647 -- task type T is 648 -- entry Fam (Index); -- (2) 649 -- entry E; 650 -- end T; 651 -- package body Inner is -- (3) 652 -- procedure P is 653 -- begin 654 -- T.E; -- (1) 655 -- end P; 656 -- end Inner; 657 -- ... 658 659 -- We are currently building the index expression for the entry 660 -- call "T.E" (1). Part of the expansion must mention the range 661 -- of the discrete type "Index" (2) of entry family "Fam". 662 663 -- However only the private view of type "Index" is available to 664 -- the inner generic (3) because there was no prior mention of 665 -- the type inside "Inner". This visibility requirement is 666 -- implicit and cannot be detected during the construction of 667 -- the generic trees and needs special handling. 668 669 if In_Instance_Body 670 and then Is_Private_Type (S) 671 and then Present (Full_View (S)) 672 then 673 S := Full_View (S); 674 end if; 675 676 Lo := Type_Low_Bound (S); 677 Hi := Type_High_Bound (S); 678 679 Expr := 680 Make_Op_Add (Sloc, 681 Left_Opnd => Expr, 682 Right_Opnd => 683 Make_Op_Add (Sloc, 684 Left_Opnd => Actual_Family_Offset (Hi, Lo), 685 Right_Opnd => Make_Integer_Literal (Sloc, 1))); 686 687 -- Other components are anonymous types to be ignored 688 689 else 690 null; 691 end if; 692 693 Next_Entity (Prev); 694 end loop; 695 696 return Expr; 697 end Actual_Index_Expression; 698 699 -------------------------- 700 -- Add_Formal_Renamings -- 701 -------------------------- 702 703 procedure Add_Formal_Renamings 704 (Spec : Node_Id; 705 Decls : List_Id; 706 Ent : Entity_Id; 707 Loc : Source_Ptr) 708 is 709 Ptr : constant Entity_Id := 710 Defining_Identifier 711 (Next (First (Parameter_Specifications (Spec)))); 712 -- The name of the formal that holds the address of the parameter block 713 -- for the call. 714 715 Comp : Entity_Id; 716 Decl : Node_Id; 717 Formal : Entity_Id; 718 New_F : Entity_Id; 719 Renamed_Formal : Node_Id; 720 721 begin 722 Formal := First_Formal (Ent); 723 while Present (Formal) loop 724 Comp := Entry_Component (Formal); 725 New_F := 726 Make_Defining_Identifier (Sloc (Formal), 727 Chars => Chars (Formal)); 728 Set_Etype (New_F, Etype (Formal)); 729 Set_Scope (New_F, Ent); 730 731 -- Now we set debug info needed on New_F even though it does not come 732 -- from source, so that the debugger will get the right information 733 -- for these generated names. 734 735 Set_Debug_Info_Needed (New_F); 736 737 if Ekind (Formal) = E_In_Parameter then 738 Set_Ekind (New_F, E_Constant); 739 else 740 Set_Ekind (New_F, E_Variable); 741 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 742 end if; 743 744 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 745 746 Renamed_Formal := 747 Make_Selected_Component (Loc, 748 Prefix => 749 Make_Explicit_Dereference (Loc, 750 Unchecked_Convert_To (Entry_Parameters_Type (Ent), 751 Make_Identifier (Loc, Chars (Ptr)))), 752 Selector_Name => New_Occurrence_Of (Comp, Loc)); 753 754 Decl := 755 Build_Renamed_Formal_Declaration 756 (New_F, Formal, Comp, Renamed_Formal); 757 758 Append (Decl, Decls); 759 Set_Renamed_Object (Formal, New_F); 760 Next_Formal (Formal); 761 end loop; 762 end Add_Formal_Renamings; 763 764 ------------------------ 765 -- Add_Object_Pointer -- 766 ------------------------ 767 768 procedure Add_Object_Pointer 769 (Loc : Source_Ptr; 770 Conc_Typ : Entity_Id; 771 Decls : List_Id) 772 is 773 Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ); 774 Decl : Node_Id; 775 Obj_Ptr : Node_Id; 776 777 begin 778 -- Create the renaming declaration for the Protection object of a 779 -- protected type. _Object is used by Complete_Entry_Body. 780 -- ??? An attempt to make this a renaming was unsuccessful. 781 782 -- Build the entity for the access type 783 784 Obj_Ptr := 785 Make_Defining_Identifier (Loc, 786 New_External_Name (Chars (Rec_Typ), 'P')); 787 788 -- Generate: 789 -- _object : poVP := poVP!O; 790 791 Decl := 792 Make_Object_Declaration (Loc, 793 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uObject), 794 Object_Definition => New_Occurrence_Of (Obj_Ptr, Loc), 795 Expression => 796 Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO))); 797 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 798 Prepend_To (Decls, Decl); 799 800 -- Generate: 801 -- type poVP is access poV; 802 803 Decl := 804 Make_Full_Type_Declaration (Loc, 805 Defining_Identifier => 806 Obj_Ptr, 807 Type_Definition => 808 Make_Access_To_Object_Definition (Loc, 809 Subtype_Indication => 810 New_Occurrence_Of (Rec_Typ, Loc))); 811 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 812 Prepend_To (Decls, Decl); 813 end Add_Object_Pointer; 814 815 ----------------------- 816 -- Build_Accept_Body -- 817 ----------------------- 818 819 function Build_Accept_Body (Astat : Node_Id) return Node_Id is 820 Loc : constant Source_Ptr := Sloc (Astat); 821 Stats : constant Node_Id := Handled_Statement_Sequence (Astat); 822 New_S : Node_Id; 823 Hand : Node_Id; 824 Call : Node_Id; 825 Ohandle : Node_Id; 826 827 begin 828 -- At the end of the statement sequence, Complete_Rendezvous is called. 829 -- A label skipping the Complete_Rendezvous, and all other accept 830 -- processing, has already been added for the expansion of requeue 831 -- statements. The Sloc is copied from the last statement since it 832 -- is really part of this last statement. 833 834 Call := 835 Build_Runtime_Call 836 (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous); 837 Insert_Before (Last (Statements (Stats)), Call); 838 Analyze (Call); 839 840 -- Ada 2020 (AI12-0279) 841 842 if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat))) 843 and then RTE_Available (RE_Yield) 844 then 845 Insert_Action_After (Call, 846 Make_Procedure_Call_Statement (Loc, 847 New_Occurrence_Of (RTE (RE_Yield), Loc))); 848 end if; 849 850 -- If exception handlers are present, then append Complete_Rendezvous 851 -- calls to the handlers, and construct the required outer block. As 852 -- above, the Sloc is copied from the last statement in the sequence. 853 854 if Present (Exception_Handlers (Stats)) then 855 Hand := First (Exception_Handlers (Stats)); 856 while Present (Hand) loop 857 Call := 858 Build_Runtime_Call 859 (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous); 860 Append (Call, Statements (Hand)); 861 Analyze (Call); 862 863 -- Ada 2020 (AI12-0279) 864 865 if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat))) 866 and then RTE_Available (RE_Yield) 867 then 868 Insert_Action_After (Call, 869 Make_Procedure_Call_Statement (Loc, 870 New_Occurrence_Of (RTE (RE_Yield), Loc))); 871 end if; 872 873 Next (Hand); 874 end loop; 875 876 New_S := 877 Make_Handled_Sequence_Of_Statements (Loc, 878 Statements => New_List ( 879 Make_Block_Statement (Loc, 880 Handled_Statement_Sequence => Stats))); 881 882 else 883 New_S := Stats; 884 end if; 885 886 -- At this stage we know that the new statement sequence does 887 -- not have an exception handler part, so we supply one to call 888 -- Exceptional_Complete_Rendezvous. This handler is 889 890 -- when all others => 891 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 892 893 -- We handle Abort_Signal to make sure that we properly catch the abort 894 -- case and wake up the caller. 895 896 Call := 897 Make_Procedure_Call_Statement (Sloc (Stats), 898 Name => New_Occurrence_Of ( 899 RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)), 900 Parameter_Associations => New_List ( 901 Make_Function_Call (Sloc (Stats), 902 Name => 903 New_Occurrence_Of 904 (RTE (RE_Get_GNAT_Exception), Sloc (Stats))))); 905 906 Ohandle := Make_Others_Choice (Loc); 907 Set_All_Others (Ohandle); 908 909 Set_Exception_Handlers (New_S, 910 New_List ( 911 Make_Implicit_Exception_Handler (Loc, 912 Exception_Choices => New_List (Ohandle), 913 914 Statements => New_List (Call)))); 915 916 -- Ada 2020 (AI12-0279) 917 918 if Has_Yield_Aspect (Entity (Entry_Direct_Name (Astat))) 919 and then RTE_Available (RE_Yield) 920 then 921 Insert_Action_After (Call, 922 Make_Procedure_Call_Statement (Loc, 923 New_Occurrence_Of (RTE (RE_Yield), Loc))); 924 end if; 925 926 Set_Parent (New_S, Astat); -- temp parent for Analyze call 927 Analyze_Exception_Handlers (Exception_Handlers (New_S)); 928 Expand_Exception_Handlers (New_S); 929 930 -- Exceptional_Complete_Rendezvous must be called with abort still 931 -- deferred, which is the case for a "when all others" handler. 932 933 return New_S; 934 end Build_Accept_Body; 935 936 ----------------------------------- 937 -- Build_Activation_Chain_Entity -- 938 ----------------------------------- 939 940 procedure Build_Activation_Chain_Entity (N : Node_Id) is 941 function Has_Activation_Chain (Stmt : Node_Id) return Boolean; 942 -- Determine whether an extended return statement has activation chain 943 944 -------------------------- 945 -- Has_Activation_Chain -- 946 -------------------------- 947 948 function Has_Activation_Chain (Stmt : Node_Id) return Boolean is 949 Decl : Node_Id; 950 951 begin 952 Decl := First (Return_Object_Declarations (Stmt)); 953 while Present (Decl) loop 954 if Nkind (Decl) = N_Object_Declaration 955 and then Chars (Defining_Identifier (Decl)) = Name_uChain 956 then 957 return True; 958 end if; 959 960 Next (Decl); 961 end loop; 962 963 return False; 964 end Has_Activation_Chain; 965 966 -- Local variables 967 968 Context : Node_Id; 969 Context_Id : Entity_Id; 970 Decls : List_Id; 971 972 -- Start of processing for Build_Activation_Chain_Entity 973 974 begin 975 -- No action needed if the run-time has no tasking support 976 977 if Global_No_Tasking then 978 return; 979 end if; 980 981 -- Activation chain is never used for sequential elaboration policy, see 982 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 983 984 if Partition_Elaboration_Policy = 'S' then 985 return; 986 end if; 987 988 Find_Enclosing_Context (N, Context, Context_Id, Decls); 989 990 -- If activation chain entity has not been declared already, create one 991 992 if Nkind (Context) = N_Extended_Return_Statement 993 or else No (Activation_Chain_Entity (Context)) 994 then 995 -- Since extended return statements do not store the entity of the 996 -- chain, examine the return object declarations to avoid creating 997 -- a duplicate. 998 999 if Nkind (Context) = N_Extended_Return_Statement 1000 and then Has_Activation_Chain (Context) 1001 then 1002 return; 1003 end if; 1004 1005 declare 1006 Loc : constant Source_Ptr := Sloc (Context); 1007 Chain : Entity_Id; 1008 Decl : Node_Id; 1009 1010 begin 1011 Chain := Make_Defining_Identifier (Sloc (N), Name_uChain); 1012 1013 -- Note: An extended return statement is not really a task 1014 -- activator, but it does have an activation chain on which to 1015 -- store the tasks temporarily. On successful return, the tasks 1016 -- on this chain are moved to the chain passed in by the caller. 1017 -- We do not build an Activation_Chain_Entity for an extended 1018 -- return statement, because we do not want to build a call to 1019 -- Activate_Tasks. Task activation is the responsibility of the 1020 -- caller. 1021 1022 if Nkind (Context) /= N_Extended_Return_Statement then 1023 Set_Activation_Chain_Entity (Context, Chain); 1024 end if; 1025 1026 Decl := 1027 Make_Object_Declaration (Loc, 1028 Defining_Identifier => Chain, 1029 Aliased_Present => True, 1030 Object_Definition => 1031 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)); 1032 1033 Prepend_To (Decls, Decl); 1034 1035 -- Ensure that _chain appears in the proper scope of the context 1036 1037 if Context_Id /= Current_Scope then 1038 Push_Scope (Context_Id); 1039 Analyze (Decl); 1040 Pop_Scope; 1041 else 1042 Analyze (Decl); 1043 end if; 1044 end; 1045 end if; 1046 end Build_Activation_Chain_Entity; 1047 1048 ---------------------------- 1049 -- Build_Barrier_Function -- 1050 ---------------------------- 1051 1052 function Build_Barrier_Function 1053 (N : Node_Id; 1054 Ent : Entity_Id; 1055 Pid : Node_Id) return Node_Id 1056 is 1057 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); 1058 Cond : constant Node_Id := Condition (Ent_Formals); 1059 Loc : constant Source_Ptr := Sloc (Cond); 1060 Func_Id : constant Entity_Id := Barrier_Function (Ent); 1061 Op_Decls : constant List_Id := New_List; 1062 Stmt : Node_Id; 1063 Func_Body : Node_Id; 1064 1065 begin 1066 -- Add a declaration for the Protection object, renaming declarations 1067 -- for the discriminals and privals and finally a declaration for the 1068 -- entry family index (if applicable). 1069 1070 Install_Private_Data_Declarations (Sloc (N), 1071 Spec_Id => Func_Id, 1072 Conc_Typ => Pid, 1073 Body_Nod => N, 1074 Decls => Op_Decls, 1075 Barrier => True, 1076 Family => Ekind (Ent) = E_Entry_Family); 1077 1078 -- If compiling with -fpreserve-control-flow, make sure we insert an 1079 -- IF statement so that the back-end knows to generate a conditional 1080 -- branch instruction, even if the condition is just the name of a 1081 -- boolean object. Note that Expand_N_If_Statement knows to preserve 1082 -- such redundant IF statements under -fpreserve-control-flow 1083 -- (whether coming from this routine, or directly from source). 1084 1085 if Opt.Suppress_Control_Flow_Optimizations then 1086 Stmt := 1087 Make_Implicit_If_Statement (Cond, 1088 Condition => Cond, 1089 Then_Statements => New_List ( 1090 Make_Simple_Return_Statement (Loc, 1091 New_Occurrence_Of (Standard_True, Loc))), 1092 1093 Else_Statements => New_List ( 1094 Make_Simple_Return_Statement (Loc, 1095 New_Occurrence_Of (Standard_False, Loc)))); 1096 1097 else 1098 Stmt := Make_Simple_Return_Statement (Loc, Cond); 1099 end if; 1100 1101 -- Note: the condition in the barrier function needs to be properly 1102 -- processed for the C/Fortran boolean possibility, but this happens 1103 -- automatically since the return statement does this normalization. 1104 1105 Func_Body := 1106 Make_Subprogram_Body (Loc, 1107 Specification => 1108 Build_Barrier_Function_Specification (Loc, 1109 Make_Defining_Identifier (Loc, Chars (Func_Id))), 1110 Declarations => Op_Decls, 1111 Handled_Statement_Sequence => 1112 Make_Handled_Sequence_Of_Statements (Loc, 1113 Statements => New_List (Stmt))); 1114 Set_Is_Entry_Barrier_Function (Func_Body); 1115 1116 return Func_Body; 1117 end Build_Barrier_Function; 1118 1119 ------------------------------------------ 1120 -- Build_Barrier_Function_Specification -- 1121 ------------------------------------------ 1122 1123 function Build_Barrier_Function_Specification 1124 (Loc : Source_Ptr; 1125 Def_Id : Entity_Id) return Node_Id 1126 is 1127 begin 1128 Set_Debug_Info_Needed (Def_Id); 1129 1130 return 1131 Make_Function_Specification (Loc, 1132 Defining_Unit_Name => Def_Id, 1133 Parameter_Specifications => New_List ( 1134 Make_Parameter_Specification (Loc, 1135 Defining_Identifier => 1136 Make_Defining_Identifier (Loc, Name_uO), 1137 Parameter_Type => 1138 New_Occurrence_Of (RTE (RE_Address), Loc)), 1139 1140 Make_Parameter_Specification (Loc, 1141 Defining_Identifier => 1142 Make_Defining_Identifier (Loc, Name_uE), 1143 Parameter_Type => 1144 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), 1145 1146 Result_Definition => 1147 New_Occurrence_Of (Standard_Boolean, Loc)); 1148 end Build_Barrier_Function_Specification; 1149 1150 -------------------------- 1151 -- Build_Call_With_Task -- 1152 -------------------------- 1153 1154 function Build_Call_With_Task 1155 (N : Node_Id; 1156 E : Entity_Id) return Node_Id 1157 is 1158 Loc : constant Source_Ptr := Sloc (N); 1159 begin 1160 return 1161 Make_Function_Call (Loc, 1162 Name => New_Occurrence_Of (E, Loc), 1163 Parameter_Associations => New_List (Concurrent_Ref (N))); 1164 end Build_Call_With_Task; 1165 1166 ----------------------------- 1167 -- Build_Class_Wide_Master -- 1168 ----------------------------- 1169 1170 procedure Build_Class_Wide_Master (Typ : Entity_Id) is 1171 Loc : constant Source_Ptr := Sloc (Typ); 1172 Master_Decl : Node_Id; 1173 Master_Id : Entity_Id; 1174 Master_Scope : Entity_Id; 1175 Name_Id : Node_Id; 1176 Related_Node : Node_Id; 1177 Ren_Decl : Node_Id; 1178 1179 begin 1180 -- No action needed if the run-time has no tasking support 1181 1182 if Global_No_Tasking then 1183 return; 1184 end if; 1185 1186 -- Find the declaration that created the access type, which is either a 1187 -- type declaration, or an object declaration with an access definition, 1188 -- in which case the type is anonymous. 1189 1190 if Is_Itype (Typ) then 1191 Related_Node := Associated_Node_For_Itype (Typ); 1192 else 1193 Related_Node := Parent (Typ); 1194 end if; 1195 1196 Master_Scope := Find_Master_Scope (Typ); 1197 1198 -- Nothing to do if the master scope already contains a _master entity. 1199 -- The only exception to this is the following scenario: 1200 1201 -- Source_Scope 1202 -- Transient_Scope_1 1203 -- _master 1204 1205 -- Transient_Scope_2 1206 -- use of master 1207 1208 -- In this case the source scope is marked as having the master entity 1209 -- even though the actual declaration appears inside an inner scope. If 1210 -- the second transient scope requires a _master, it cannot use the one 1211 -- already declared because the entity is not visible. 1212 1213 Name_Id := Make_Identifier (Loc, Name_uMaster); 1214 Master_Decl := Empty; 1215 1216 if not Has_Master_Entity (Master_Scope) 1217 or else No (Current_Entity_In_Scope (Name_Id)) 1218 then 1219 declare 1220 Ins_Nod : Node_Id; 1221 1222 begin 1223 Set_Has_Master_Entity (Master_Scope); 1224 Master_Decl := Build_Master_Declaration (Loc); 1225 1226 -- Ensure that the master declaration is placed before its use 1227 1228 Ins_Nod := Find_Hook_Context (Related_Node); 1229 while not Is_List_Member (Ins_Nod) loop 1230 Ins_Nod := Parent (Ins_Nod); 1231 end loop; 1232 1233 Insert_Before (First (List_Containing (Ins_Nod)), Master_Decl); 1234 Analyze (Master_Decl); 1235 1236 -- Mark the containing scope as a task master. Masters associated 1237 -- with return statements are already marked at this stage (see 1238 -- Analyze_Subprogram_Body). 1239 1240 if Ekind (Current_Scope) /= E_Return_Statement then 1241 declare 1242 Par : Node_Id := Related_Node; 1243 1244 begin 1245 while Nkind (Par) /= N_Compilation_Unit loop 1246 Par := Parent (Par); 1247 1248 -- If we fall off the top, we are at the outer level, 1249 -- and the environment task is our effective master, 1250 -- so nothing to mark. 1251 1252 if Nkind (Par) in 1253 N_Block_Statement | N_Subprogram_Body | N_Task_Body 1254 then 1255 Set_Is_Task_Master (Par); 1256 exit; 1257 end if; 1258 end loop; 1259 end; 1260 end if; 1261 end; 1262 end if; 1263 1264 Master_Id := 1265 Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'M')); 1266 1267 -- Generate: 1268 -- typeMnn renames _master; 1269 1270 Ren_Decl := 1271 Make_Object_Renaming_Declaration (Loc, 1272 Defining_Identifier => Master_Id, 1273 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), 1274 Name => Name_Id); 1275 1276 -- If the master is declared locally, add the renaming declaration 1277 -- immediately after it, to prevent access-before-elaboration in the 1278 -- back-end. 1279 1280 if Present (Master_Decl) then 1281 Insert_After (Master_Decl, Ren_Decl); 1282 Analyze (Ren_Decl); 1283 1284 else 1285 Insert_Action (Related_Node, Ren_Decl); 1286 end if; 1287 1288 Set_Master_Id (Typ, Master_Id); 1289 end Build_Class_Wide_Master; 1290 1291 ---------------------------- 1292 -- Build_Contract_Wrapper -- 1293 ---------------------------- 1294 1295 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id) is 1296 Conc_Typ : constant Entity_Id := Scope (E); 1297 Loc : constant Source_Ptr := Sloc (E); 1298 1299 procedure Add_Discriminant_Renamings 1300 (Obj_Id : Entity_Id; 1301 Decls : List_Id); 1302 -- Add renaming declarations for all discriminants of concurrent type 1303 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which 1304 -- represents the concurrent object. 1305 1306 procedure Add_Matching_Formals 1307 (Formals : List_Id; 1308 Actuals : in out List_Id); 1309 -- Add formal parameters that match those of entry E to list Formals. 1310 -- The routine also adds matching actuals for the new formals to list 1311 -- Actuals. 1312 1313 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id); 1314 -- Relocate pragma Prag to list To. The routine creates a new list if 1315 -- To does not exist. 1316 1317 -------------------------------- 1318 -- Add_Discriminant_Renamings -- 1319 -------------------------------- 1320 1321 procedure Add_Discriminant_Renamings 1322 (Obj_Id : Entity_Id; 1323 Decls : List_Id) 1324 is 1325 Discr : Entity_Id; 1326 1327 begin 1328 -- Inspect the discriminants of the concurrent type and generate a 1329 -- renaming for each one. 1330 1331 if Has_Discriminants (Conc_Typ) then 1332 Discr := First_Discriminant (Conc_Typ); 1333 while Present (Discr) loop 1334 Prepend_To (Decls, 1335 Make_Object_Renaming_Declaration (Loc, 1336 Defining_Identifier => 1337 Make_Defining_Identifier (Loc, Chars (Discr)), 1338 Subtype_Mark => 1339 New_Occurrence_Of (Etype (Discr), Loc), 1340 Name => 1341 Make_Selected_Component (Loc, 1342 Prefix => New_Occurrence_Of (Obj_Id, Loc), 1343 Selector_Name => 1344 Make_Identifier (Loc, Chars (Discr))))); 1345 1346 Next_Discriminant (Discr); 1347 end loop; 1348 end if; 1349 end Add_Discriminant_Renamings; 1350 1351 -------------------------- 1352 -- Add_Matching_Formals -- 1353 -------------------------- 1354 1355 procedure Add_Matching_Formals 1356 (Formals : List_Id; 1357 Actuals : in out List_Id) 1358 is 1359 Formal : Entity_Id; 1360 New_Formal : Entity_Id; 1361 1362 begin 1363 -- Inspect the formal parameters of the entry and generate a new 1364 -- matching formal with the same name for the wrapper. A reference 1365 -- to the new formal becomes an actual in the entry call. 1366 1367 Formal := First_Formal (E); 1368 while Present (Formal) loop 1369 New_Formal := Make_Defining_Identifier (Loc, Chars (Formal)); 1370 Append_To (Formals, 1371 Make_Parameter_Specification (Loc, 1372 Defining_Identifier => New_Formal, 1373 In_Present => In_Present (Parent (Formal)), 1374 Out_Present => Out_Present (Parent (Formal)), 1375 Parameter_Type => 1376 New_Occurrence_Of (Etype (Formal), Loc))); 1377 1378 if No (Actuals) then 1379 Actuals := New_List; 1380 end if; 1381 1382 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); 1383 Next_Formal (Formal); 1384 end loop; 1385 end Add_Matching_Formals; 1386 1387 --------------------- 1388 -- Transfer_Pragma -- 1389 --------------------- 1390 1391 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id) is 1392 New_Prag : Node_Id; 1393 1394 begin 1395 if No (To) then 1396 To := New_List; 1397 end if; 1398 1399 New_Prag := Relocate_Node (Prag); 1400 1401 Set_Analyzed (New_Prag, False); 1402 Append (New_Prag, To); 1403 end Transfer_Pragma; 1404 1405 -- Local variables 1406 1407 Items : constant Node_Id := Contract (E); 1408 Actuals : List_Id := No_List; 1409 Call : Node_Id; 1410 Call_Nam : Node_Id; 1411 Decls : List_Id := No_List; 1412 Formals : List_Id; 1413 Has_Pragma : Boolean := False; 1414 Index_Id : Entity_Id; 1415 Obj_Id : Entity_Id; 1416 Prag : Node_Id; 1417 Wrapper_Id : Entity_Id; 1418 1419 -- Start of processing for Build_Contract_Wrapper 1420 1421 begin 1422 -- This routine generates a specialized wrapper for a protected or task 1423 -- entry [family] which implements precondition/postcondition semantics. 1424 -- Preconditions and case guards of contract cases are checked before 1425 -- the protected action or rendezvous takes place. Postconditions and 1426 -- consequences of contract cases are checked after the protected action 1427 -- or rendezvous takes place. The structure of the generated wrapper is 1428 -- as follows: 1429 1430 -- procedure Wrapper 1431 -- (Obj_Id : Conc_Typ; -- concurrent object 1432 -- [Index : Index_Typ;] -- index of entry family 1433 -- [Formal_1 : ...; -- parameters of original entry 1434 -- Formal_N : ...]) 1435 -- is 1436 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant 1437 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings 1438 1439 -- <precondition checks> 1440 -- <case guard checks> 1441 1442 -- procedure _Postconditions is 1443 -- begin 1444 -- <postcondition checks> 1445 -- <consequence checks> 1446 -- end _Postconditions; 1447 1448 -- begin 1449 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]); 1450 -- _Postconditions; 1451 -- end Wrapper; 1452 1453 -- Create the wrapper only when the entry has at least one executable 1454 -- contract item such as contract cases, precondition or postcondition. 1455 1456 if Present (Items) then 1457 1458 -- Inspect the list of pre/postconditions and transfer all available 1459 -- pragmas to the declarative list of the wrapper. 1460 1461 Prag := Pre_Post_Conditions (Items); 1462 while Present (Prag) loop 1463 if Pragma_Name_Unmapped (Prag) in Name_Postcondition 1464 | Name_Precondition 1465 and then Is_Checked (Prag) 1466 then 1467 Has_Pragma := True; 1468 Transfer_Pragma (Prag, To => Decls); 1469 end if; 1470 1471 Prag := Next_Pragma (Prag); 1472 end loop; 1473 1474 -- Inspect the list of test/contract cases and transfer only contract 1475 -- cases pragmas to the declarative part of the wrapper. 1476 1477 Prag := Contract_Test_Cases (Items); 1478 while Present (Prag) loop 1479 if Pragma_Name (Prag) = Name_Contract_Cases 1480 and then Is_Checked (Prag) 1481 then 1482 Has_Pragma := True; 1483 Transfer_Pragma (Prag, To => Decls); 1484 end if; 1485 1486 Prag := Next_Pragma (Prag); 1487 end loop; 1488 end if; 1489 1490 -- The entry lacks executable contract items and a wrapper is not needed 1491 1492 if not Has_Pragma then 1493 return; 1494 end if; 1495 1496 -- Create the profile of the wrapper. The first formal parameter is the 1497 -- concurrent object. 1498 1499 Obj_Id := 1500 Make_Defining_Identifier (Loc, 1501 Chars => New_External_Name (Chars (Conc_Typ), 'A')); 1502 1503 Formals := New_List ( 1504 Make_Parameter_Specification (Loc, 1505 Defining_Identifier => Obj_Id, 1506 Out_Present => True, 1507 In_Present => True, 1508 Parameter_Type => New_Occurrence_Of (Conc_Typ, Loc))); 1509 1510 -- Construct the call to the original entry. The call will be gradually 1511 -- augmented with an optional entry index and extra parameters. 1512 1513 Call_Nam := 1514 Make_Selected_Component (Loc, 1515 Prefix => New_Occurrence_Of (Obj_Id, Loc), 1516 Selector_Name => New_Occurrence_Of (E, Loc)); 1517 1518 -- When creating a wrapper for an entry family, the second formal is the 1519 -- entry index. 1520 1521 if Ekind (E) = E_Entry_Family then 1522 Index_Id := Make_Defining_Identifier (Loc, Name_I); 1523 1524 Append_To (Formals, 1525 Make_Parameter_Specification (Loc, 1526 Defining_Identifier => Index_Id, 1527 Parameter_Type => 1528 New_Occurrence_Of (Entry_Index_Type (E), Loc))); 1529 1530 -- The call to the original entry becomes an indexed component to 1531 -- accommodate the entry index. 1532 1533 Call_Nam := 1534 Make_Indexed_Component (Loc, 1535 Prefix => Call_Nam, 1536 Expressions => New_List (New_Occurrence_Of (Index_Id, Loc))); 1537 end if; 1538 1539 -- Add formal parameters to match those of the entry and build actuals 1540 -- for the entry call. 1541 1542 Add_Matching_Formals (Formals, Actuals); 1543 1544 Call := 1545 Make_Procedure_Call_Statement (Loc, 1546 Name => Call_Nam, 1547 Parameter_Associations => Actuals); 1548 1549 -- Add renaming declarations for the discriminants of the enclosing type 1550 -- as the various contract items may reference them. 1551 1552 Add_Discriminant_Renamings (Obj_Id, Decls); 1553 1554 Wrapper_Id := 1555 Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E')); 1556 Set_Contract_Wrapper (E, Wrapper_Id); 1557 Set_Is_Entry_Wrapper (Wrapper_Id); 1558 1559 -- The wrapper body is analyzed when the enclosing type is frozen 1560 1561 Append_Freeze_Action (Defining_Entity (Decl), 1562 Make_Subprogram_Body (Loc, 1563 Specification => 1564 Make_Procedure_Specification (Loc, 1565 Defining_Unit_Name => Wrapper_Id, 1566 Parameter_Specifications => Formals), 1567 Declarations => Decls, 1568 Handled_Statement_Sequence => 1569 Make_Handled_Sequence_Of_Statements (Loc, 1570 Statements => New_List (Call)))); 1571 end Build_Contract_Wrapper; 1572 1573 -------------------------------- 1574 -- Build_Corresponding_Record -- 1575 -------------------------------- 1576 1577 function Build_Corresponding_Record 1578 (N : Node_Id; 1579 Ctyp : Entity_Id; 1580 Loc : Source_Ptr) return Node_Id 1581 is 1582 Rec_Ent : constant Entity_Id := 1583 Make_Defining_Identifier 1584 (Loc, New_External_Name (Chars (Ctyp), 'V')); 1585 Disc : Entity_Id; 1586 Dlist : List_Id; 1587 New_Disc : Entity_Id; 1588 Cdecls : List_Id; 1589 1590 begin 1591 Set_Corresponding_Record_Type (Ctyp, Rec_Ent); 1592 Set_Ekind (Rec_Ent, E_Record_Type); 1593 Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp)); 1594 Set_Is_Concurrent_Record_Type (Rec_Ent, True); 1595 Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp); 1596 Set_Stored_Constraint (Rec_Ent, No_Elist); 1597 Cdecls := New_List; 1598 1599 -- Use discriminals to create list of discriminants for record, and 1600 -- create new discriminals for use in default expressions, etc. It is 1601 -- worth noting that a task discriminant gives rise to 5 entities; 1602 1603 -- a) The original discriminant. 1604 -- b) The discriminal for use in the task. 1605 -- c) The discriminant of the corresponding record. 1606 -- d) The discriminal for the init proc of the corresponding record. 1607 -- e) The local variable that renames the discriminant in the procedure 1608 -- for the task body. 1609 1610 -- In fact the discriminals b) are used in the renaming declarations 1611 -- for e). See details in einfo (Handling of Discriminants). 1612 1613 if Present (Discriminant_Specifications (N)) then 1614 Dlist := New_List; 1615 Disc := First_Discriminant (Ctyp); 1616 1617 while Present (Disc) loop 1618 New_Disc := CR_Discriminant (Disc); 1619 1620 Append_To (Dlist, 1621 Make_Discriminant_Specification (Loc, 1622 Defining_Identifier => New_Disc, 1623 Discriminant_Type => 1624 New_Occurrence_Of (Etype (Disc), Loc), 1625 Expression => 1626 New_Copy (Discriminant_Default_Value (Disc)))); 1627 1628 Next_Discriminant (Disc); 1629 end loop; 1630 1631 else 1632 Dlist := No_List; 1633 end if; 1634 1635 -- Now we can construct the record type declaration. Note that this 1636 -- record is "limited tagged". It is "limited" to reflect the underlying 1637 -- limitedness of the task or protected object that it represents, and 1638 -- ensuring for example that it is properly passed by reference. It is 1639 -- "tagged" to give support to dispatching calls through interfaces. We 1640 -- propagate here the list of interfaces covered by the concurrent type 1641 -- (Ada 2005: AI-345). 1642 1643 return 1644 Make_Full_Type_Declaration (Loc, 1645 Defining_Identifier => Rec_Ent, 1646 Discriminant_Specifications => Dlist, 1647 Type_Definition => 1648 Make_Record_Definition (Loc, 1649 Component_List => 1650 Make_Component_List (Loc, Component_Items => Cdecls), 1651 Tagged_Present => 1652 Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp), 1653 Interface_List => Interface_List (N), 1654 Limited_Present => True)); 1655 end Build_Corresponding_Record; 1656 1657 --------------------------------- 1658 -- Build_Dispatching_Tag_Check -- 1659 --------------------------------- 1660 1661 function Build_Dispatching_Tag_Check 1662 (K : Entity_Id; 1663 N : Node_Id) return Node_Id 1664 is 1665 Loc : constant Source_Ptr := Sloc (N); 1666 1667 begin 1668 return 1669 Make_Op_Or (Loc, 1670 Make_Op_Eq (Loc, 1671 Left_Opnd => 1672 New_Occurrence_Of (K, Loc), 1673 Right_Opnd => 1674 New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc)), 1675 1676 Make_Op_Eq (Loc, 1677 Left_Opnd => 1678 New_Occurrence_Of (K, Loc), 1679 Right_Opnd => 1680 New_Occurrence_Of (RTE (RE_TK_Tagged), Loc))); 1681 end Build_Dispatching_Tag_Check; 1682 1683 ---------------------------------- 1684 -- Build_Entry_Count_Expression -- 1685 ---------------------------------- 1686 1687 function Build_Entry_Count_Expression 1688 (Concurrent_Type : Node_Id; 1689 Component_List : List_Id; 1690 Loc : Source_Ptr) return Node_Id 1691 is 1692 Eindx : Nat; 1693 Ent : Entity_Id; 1694 Ecount : Node_Id; 1695 Comp : Node_Id; 1696 Lo : Node_Id; 1697 Hi : Node_Id; 1698 Typ : Entity_Id; 1699 Large : Boolean; 1700 1701 begin 1702 -- Count number of non-family entries 1703 1704 Eindx := 0; 1705 Ent := First_Entity (Concurrent_Type); 1706 while Present (Ent) loop 1707 if Ekind (Ent) = E_Entry then 1708 Eindx := Eindx + 1; 1709 end if; 1710 1711 Next_Entity (Ent); 1712 end loop; 1713 1714 Ecount := Make_Integer_Literal (Loc, Eindx); 1715 1716 -- Loop through entry families building the addition nodes 1717 1718 Ent := First_Entity (Concurrent_Type); 1719 Comp := First (Component_List); 1720 while Present (Ent) loop 1721 if Ekind (Ent) = E_Entry_Family then 1722 while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop 1723 Next (Comp); 1724 end loop; 1725 1726 Typ := Entry_Index_Type (Ent); 1727 Hi := Type_High_Bound (Typ); 1728 Lo := Type_Low_Bound (Typ); 1729 Large := Is_Potentially_Large_Family 1730 (Base_Type (Typ), Concurrent_Type, Lo, Hi); 1731 Ecount := 1732 Make_Op_Add (Loc, 1733 Left_Opnd => Ecount, 1734 Right_Opnd => 1735 Family_Size (Loc, Hi, Lo, Concurrent_Type, Large)); 1736 end if; 1737 1738 Next_Entity (Ent); 1739 end loop; 1740 1741 return Ecount; 1742 end Build_Entry_Count_Expression; 1743 1744 ------------------------------ 1745 -- Build_Master_Declaration -- 1746 ------------------------------ 1747 1748 function Build_Master_Declaration (Loc : Source_Ptr) return Node_Id is 1749 Master_Decl : Node_Id; 1750 1751 begin 1752 -- Generate a dummy master if tasks or tasking hierarchies are 1753 -- prohibited. 1754 1755 -- _Master : constant Master_Id := 3; 1756 1757 if not Tasking_Allowed 1758 or else Restrictions.Set (No_Task_Hierarchy) 1759 or else not RTE_Available (RE_Current_Master) 1760 then 1761 declare 1762 Expr : Node_Id; 1763 1764 begin 1765 -- RE_Library_Task_Level is not always available in configurable 1766 -- RunTime 1767 1768 if not RTE_Available (RE_Library_Task_Level) then 1769 Expr := Make_Integer_Literal (Loc, Uint_3); 1770 else 1771 Expr := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc); 1772 end if; 1773 1774 Master_Decl := 1775 Make_Object_Declaration (Loc, 1776 Defining_Identifier => 1777 Make_Defining_Identifier (Loc, Name_uMaster), 1778 Constant_Present => True, 1779 Object_Definition => 1780 New_Occurrence_Of (Standard_Integer, Loc), 1781 Expression => Expr); 1782 end; 1783 1784 -- Generate: 1785 -- _master : constant Integer := Current_Master.all; 1786 1787 else 1788 Master_Decl := 1789 Make_Object_Declaration (Loc, 1790 Defining_Identifier => 1791 Make_Defining_Identifier (Loc, Name_uMaster), 1792 Constant_Present => True, 1793 Object_Definition => 1794 New_Occurrence_Of (Standard_Integer, Loc), 1795 Expression => 1796 Make_Explicit_Dereference (Loc, 1797 New_Occurrence_Of (RTE (RE_Current_Master), Loc))); 1798 end if; 1799 1800 return Master_Decl; 1801 end Build_Master_Declaration; 1802 1803 --------------------------- 1804 -- Build_Parameter_Block -- 1805 --------------------------- 1806 1807 function Build_Parameter_Block 1808 (Loc : Source_Ptr; 1809 Actuals : List_Id; 1810 Formals : List_Id; 1811 Decls : List_Id) return Entity_Id 1812 is 1813 Actual : Entity_Id; 1814 Comp_Nam : Node_Id; 1815 Comps : List_Id; 1816 Formal : Entity_Id; 1817 Has_Comp : Boolean := False; 1818 Rec_Nam : Node_Id; 1819 1820 begin 1821 Actual := First (Actuals); 1822 Comps := New_List; 1823 Formal := Defining_Identifier (First (Formals)); 1824 1825 while Present (Actual) loop 1826 if not Is_Controlling_Actual (Actual) then 1827 1828 -- Generate: 1829 -- type Ann is access all <actual-type> 1830 1831 Comp_Nam := Make_Temporary (Loc, 'A'); 1832 Set_Is_Param_Block_Component_Type (Comp_Nam); 1833 1834 Append_To (Decls, 1835 Make_Full_Type_Declaration (Loc, 1836 Defining_Identifier => Comp_Nam, 1837 Type_Definition => 1838 Make_Access_To_Object_Definition (Loc, 1839 All_Present => True, 1840 Constant_Present => Ekind (Formal) = E_In_Parameter, 1841 Subtype_Indication => 1842 New_Occurrence_Of (Etype (Actual), Loc)))); 1843 1844 -- Generate: 1845 -- Param : Ann; 1846 1847 Append_To (Comps, 1848 Make_Component_Declaration (Loc, 1849 Defining_Identifier => 1850 Make_Defining_Identifier (Loc, Chars (Formal)), 1851 Component_Definition => 1852 Make_Component_Definition (Loc, 1853 Aliased_Present => 1854 False, 1855 Subtype_Indication => 1856 New_Occurrence_Of (Comp_Nam, Loc)))); 1857 1858 Has_Comp := True; 1859 end if; 1860 1861 Next_Actual (Actual); 1862 Next_Formal_With_Extras (Formal); 1863 end loop; 1864 1865 Rec_Nam := Make_Temporary (Loc, 'P'); 1866 1867 if Has_Comp then 1868 1869 -- Generate: 1870 -- type Pnn is record 1871 -- Param1 : Ann1; 1872 -- ... 1873 -- ParamN : AnnN; 1874 1875 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are 1876 -- the original parameter names and Ann1 .. AnnN are the access to 1877 -- actual types. 1878 1879 Append_To (Decls, 1880 Make_Full_Type_Declaration (Loc, 1881 Defining_Identifier => 1882 Rec_Nam, 1883 Type_Definition => 1884 Make_Record_Definition (Loc, 1885 Component_List => 1886 Make_Component_List (Loc, Comps)))); 1887 else 1888 -- Generate: 1889 -- type Pnn is null record; 1890 1891 Append_To (Decls, 1892 Make_Full_Type_Declaration (Loc, 1893 Defining_Identifier => 1894 Rec_Nam, 1895 Type_Definition => 1896 Make_Record_Definition (Loc, 1897 Null_Present => True, 1898 Component_List => Empty))); 1899 end if; 1900 1901 return Rec_Nam; 1902 end Build_Parameter_Block; 1903 1904 -------------------------------------- 1905 -- Build_Renamed_Formal_Declaration -- 1906 -------------------------------------- 1907 1908 function Build_Renamed_Formal_Declaration 1909 (New_F : Entity_Id; 1910 Formal : Entity_Id; 1911 Comp : Entity_Id; 1912 Renamed_Formal : Node_Id) return Node_Id 1913 is 1914 Loc : constant Source_Ptr := Sloc (New_F); 1915 Decl : Node_Id; 1916 1917 begin 1918 -- If the formal is a tagged incomplete type, it is already passed 1919 -- by reference, so it is sufficient to rename the pointer component 1920 -- that corresponds to the actual. Otherwise we need to dereference 1921 -- the pointer component to obtain the actual. 1922 1923 if Is_Incomplete_Type (Etype (Formal)) 1924 and then Is_Tagged_Type (Etype (Formal)) 1925 then 1926 Decl := 1927 Make_Object_Renaming_Declaration (Loc, 1928 Defining_Identifier => New_F, 1929 Subtype_Mark => New_Occurrence_Of (Etype (Comp), Loc), 1930 Name => Renamed_Formal); 1931 1932 else 1933 Decl := 1934 Make_Object_Renaming_Declaration (Loc, 1935 Defining_Identifier => New_F, 1936 Subtype_Mark => New_Occurrence_Of (Etype (Formal), Loc), 1937 Name => 1938 Make_Explicit_Dereference (Loc, Renamed_Formal)); 1939 end if; 1940 1941 return Decl; 1942 end Build_Renamed_Formal_Declaration; 1943 1944 -------------------------- 1945 -- Build_Wrapper_Bodies -- 1946 -------------------------- 1947 1948 procedure Build_Wrapper_Bodies 1949 (Loc : Source_Ptr; 1950 Typ : Entity_Id; 1951 N : Node_Id) 1952 is 1953 Rec_Typ : Entity_Id; 1954 1955 function Build_Wrapper_Body 1956 (Loc : Source_Ptr; 1957 Subp_Id : Entity_Id; 1958 Obj_Typ : Entity_Id; 1959 Formals : List_Id) return Node_Id; 1960 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation 1961 -- associated with a protected or task type. Subp_Id is the subprogram 1962 -- name which will be wrapped. Obj_Typ is the type of the new formal 1963 -- parameter which handles dispatching and object notation. Formals are 1964 -- the original formals of Subp_Id which will be explicitly replicated. 1965 1966 ------------------------ 1967 -- Build_Wrapper_Body -- 1968 ------------------------ 1969 1970 function Build_Wrapper_Body 1971 (Loc : Source_Ptr; 1972 Subp_Id : Entity_Id; 1973 Obj_Typ : Entity_Id; 1974 Formals : List_Id) return Node_Id 1975 is 1976 Body_Spec : Node_Id; 1977 1978 begin 1979 Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals); 1980 1981 -- The subprogram is not overriding or is not a primitive declared 1982 -- between two views. 1983 1984 if No (Body_Spec) then 1985 return Empty; 1986 end if; 1987 1988 declare 1989 Actuals : List_Id := No_List; 1990 Conv_Id : Node_Id; 1991 First_Form : Node_Id; 1992 Formal : Node_Id; 1993 Nam : Node_Id; 1994 1995 begin 1996 -- Map formals to actuals. Use the list built for the wrapper 1997 -- spec, skipping the object notation parameter. 1998 1999 First_Form := First (Parameter_Specifications (Body_Spec)); 2000 2001 Formal := First_Form; 2002 Next (Formal); 2003 2004 if Present (Formal) then 2005 Actuals := New_List; 2006 while Present (Formal) loop 2007 Append_To (Actuals, 2008 Make_Identifier (Loc, 2009 Chars => Chars (Defining_Identifier (Formal)))); 2010 Next (Formal); 2011 end loop; 2012 end if; 2013 2014 -- Special processing for primitives declared between a private 2015 -- type and its completion: the wrapper needs a properly typed 2016 -- parameter if the wrapped operation has a controlling first 2017 -- parameter. Note that this might not be the case for a function 2018 -- with a controlling result. 2019 2020 if Is_Private_Primitive_Subprogram (Subp_Id) then 2021 if No (Actuals) then 2022 Actuals := New_List; 2023 end if; 2024 2025 if Is_Controlling_Formal (First_Formal (Subp_Id)) then 2026 Prepend_To (Actuals, 2027 Unchecked_Convert_To 2028 (Corresponding_Concurrent_Type (Obj_Typ), 2029 Make_Identifier (Loc, Name_uO))); 2030 2031 else 2032 Prepend_To (Actuals, 2033 Make_Identifier (Loc, 2034 Chars => Chars (Defining_Identifier (First_Form)))); 2035 end if; 2036 2037 Nam := New_Occurrence_Of (Subp_Id, Loc); 2038 else 2039 -- An access-to-variable object parameter requires an explicit 2040 -- dereference in the unchecked conversion. This case occurs 2041 -- when a protected entry wrapper must override an interface 2042 -- level procedure with interface access as first parameter. 2043 2044 -- O.all.Subp_Id (Formal_1, ..., Formal_N) 2045 2046 if Nkind (Parameter_Type (First_Form)) = 2047 N_Access_Definition 2048 then 2049 Conv_Id := 2050 Make_Explicit_Dereference (Loc, 2051 Prefix => Make_Identifier (Loc, Name_uO)); 2052 else 2053 Conv_Id := Make_Identifier (Loc, Name_uO); 2054 end if; 2055 2056 Nam := 2057 Make_Selected_Component (Loc, 2058 Prefix => 2059 Unchecked_Convert_To 2060 (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id), 2061 Selector_Name => New_Occurrence_Of (Subp_Id, Loc)); 2062 end if; 2063 2064 -- Create the subprogram body. For a function, the call to the 2065 -- actual subprogram has to be converted to the corresponding 2066 -- record if it is a controlling result. 2067 2068 if Ekind (Subp_Id) = E_Function then 2069 declare 2070 Res : Node_Id; 2071 2072 begin 2073 Res := 2074 Make_Function_Call (Loc, 2075 Name => Nam, 2076 Parameter_Associations => Actuals); 2077 2078 if Has_Controlling_Result (Subp_Id) then 2079 Res := 2080 Unchecked_Convert_To 2081 (Corresponding_Record_Type (Etype (Subp_Id)), Res); 2082 end if; 2083 2084 return 2085 Make_Subprogram_Body (Loc, 2086 Specification => Body_Spec, 2087 Declarations => Empty_List, 2088 Handled_Statement_Sequence => 2089 Make_Handled_Sequence_Of_Statements (Loc, 2090 Statements => New_List ( 2091 Make_Simple_Return_Statement (Loc, Res)))); 2092 end; 2093 2094 else 2095 return 2096 Make_Subprogram_Body (Loc, 2097 Specification => Body_Spec, 2098 Declarations => Empty_List, 2099 Handled_Statement_Sequence => 2100 Make_Handled_Sequence_Of_Statements (Loc, 2101 Statements => New_List ( 2102 Make_Procedure_Call_Statement (Loc, 2103 Name => Nam, 2104 Parameter_Associations => Actuals)))); 2105 end if; 2106 end; 2107 end Build_Wrapper_Body; 2108 2109 -- Start of processing for Build_Wrapper_Bodies 2110 2111 begin 2112 if Is_Concurrent_Type (Typ) then 2113 Rec_Typ := Corresponding_Record_Type (Typ); 2114 else 2115 Rec_Typ := Typ; 2116 end if; 2117 2118 -- Generate wrapper bodies for a concurrent type which implements an 2119 -- interface. 2120 2121 if Present (Interfaces (Rec_Typ)) then 2122 declare 2123 Insert_Nod : Node_Id; 2124 Prim : Entity_Id; 2125 Prim_Elmt : Elmt_Id; 2126 Prim_Decl : Node_Id; 2127 Subp : Entity_Id; 2128 Wrap_Body : Node_Id; 2129 Wrap_Id : Entity_Id; 2130 2131 begin 2132 Insert_Nod := N; 2133 2134 -- Examine all primitive operations of the corresponding record 2135 -- type, looking for wrapper specs. Generate bodies in order to 2136 -- complete them. 2137 2138 Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ)); 2139 while Present (Prim_Elmt) loop 2140 Prim := Node (Prim_Elmt); 2141 2142 if (Ekind (Prim) = E_Function 2143 or else Ekind (Prim) = E_Procedure) 2144 and then Is_Primitive_Wrapper (Prim) 2145 then 2146 Subp := Wrapped_Entity (Prim); 2147 Prim_Decl := Parent (Parent (Prim)); 2148 2149 Wrap_Body := 2150 Build_Wrapper_Body (Loc, 2151 Subp_Id => Subp, 2152 Obj_Typ => Rec_Typ, 2153 Formals => Parameter_Specifications (Parent (Subp))); 2154 Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body)); 2155 2156 Set_Corresponding_Spec (Wrap_Body, Prim); 2157 Set_Corresponding_Body (Prim_Decl, Wrap_Id); 2158 2159 Insert_After (Insert_Nod, Wrap_Body); 2160 Insert_Nod := Wrap_Body; 2161 2162 Analyze (Wrap_Body); 2163 end if; 2164 2165 Next_Elmt (Prim_Elmt); 2166 end loop; 2167 end; 2168 end if; 2169 end Build_Wrapper_Bodies; 2170 2171 ------------------------ 2172 -- Build_Wrapper_Spec -- 2173 ------------------------ 2174 2175 function Build_Wrapper_Spec 2176 (Subp_Id : Entity_Id; 2177 Obj_Typ : Entity_Id; 2178 Formals : List_Id) return Node_Id 2179 is 2180 function Overriding_Possible 2181 (Iface_Op : Entity_Id; 2182 Wrapper : Entity_Id) return Boolean; 2183 -- Determine whether a primitive operation can be overridden by Wrapper. 2184 -- Iface_Op is the candidate primitive operation of an interface type, 2185 -- Wrapper is the generated entry wrapper. 2186 2187 function Replicate_Formals 2188 (Loc : Source_Ptr; 2189 Formals : List_Id) return List_Id; 2190 -- An explicit parameter replication is required due to the Is_Entry_ 2191 -- Formal flag being set for all the formals of an entry. The explicit 2192 -- replication removes the flag that would otherwise cause a different 2193 -- path of analysis. 2194 2195 ------------------------- 2196 -- Overriding_Possible -- 2197 ------------------------- 2198 2199 function Overriding_Possible 2200 (Iface_Op : Entity_Id; 2201 Wrapper : Entity_Id) return Boolean 2202 is 2203 Iface_Op_Spec : constant Node_Id := Parent (Iface_Op); 2204 Wrapper_Spec : constant Node_Id := Parent (Wrapper); 2205 2206 function Type_Conformant_Parameters 2207 (Iface_Op_Params : List_Id; 2208 Wrapper_Params : List_Id) return Boolean; 2209 -- Determine whether the parameters of the generated entry wrapper 2210 -- and those of a primitive operation are type conformant. During 2211 -- this check, the first parameter of the primitive operation is 2212 -- skipped if it is a controlling argument: protected functions 2213 -- may have a controlling result. 2214 2215 -------------------------------- 2216 -- Type_Conformant_Parameters -- 2217 -------------------------------- 2218 2219 function Type_Conformant_Parameters 2220 (Iface_Op_Params : List_Id; 2221 Wrapper_Params : List_Id) return Boolean 2222 is 2223 Iface_Op_Param : Node_Id; 2224 Iface_Op_Typ : Entity_Id; 2225 Wrapper_Param : Node_Id; 2226 Wrapper_Typ : Entity_Id; 2227 2228 begin 2229 -- Skip the first (controlling) parameter of primitive operation 2230 2231 Iface_Op_Param := First (Iface_Op_Params); 2232 2233 if Present (First_Formal (Iface_Op)) 2234 and then Is_Controlling_Formal (First_Formal (Iface_Op)) 2235 then 2236 Next (Iface_Op_Param); 2237 end if; 2238 2239 Wrapper_Param := First (Wrapper_Params); 2240 while Present (Iface_Op_Param) 2241 and then Present (Wrapper_Param) 2242 loop 2243 Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param); 2244 Wrapper_Typ := Find_Parameter_Type (Wrapper_Param); 2245 2246 -- The two parameters must be mode conformant 2247 2248 if not Conforming_Types 2249 (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant) 2250 then 2251 return False; 2252 end if; 2253 2254 Next (Iface_Op_Param); 2255 Next (Wrapper_Param); 2256 end loop; 2257 2258 -- One of the lists is longer than the other 2259 2260 if Present (Iface_Op_Param) or else Present (Wrapper_Param) then 2261 return False; 2262 end if; 2263 2264 return True; 2265 end Type_Conformant_Parameters; 2266 2267 -- Start of processing for Overriding_Possible 2268 2269 begin 2270 if Chars (Iface_Op) /= Chars (Wrapper) then 2271 return False; 2272 end if; 2273 2274 -- If an inherited subprogram is implemented by a protected procedure 2275 -- or an entry, then the first parameter of the inherited subprogram 2276 -- must be of mode OUT or IN OUT, or access-to-variable parameter. 2277 2278 if Ekind (Iface_Op) = E_Procedure 2279 and then Present (Parameter_Specifications (Iface_Op_Spec)) 2280 then 2281 declare 2282 Obj_Param : constant Node_Id := 2283 First (Parameter_Specifications (Iface_Op_Spec)); 2284 begin 2285 if not Out_Present (Obj_Param) 2286 and then Nkind (Parameter_Type (Obj_Param)) /= 2287 N_Access_Definition 2288 then 2289 return False; 2290 end if; 2291 end; 2292 end if; 2293 2294 return 2295 Type_Conformant_Parameters 2296 (Parameter_Specifications (Iface_Op_Spec), 2297 Parameter_Specifications (Wrapper_Spec)); 2298 end Overriding_Possible; 2299 2300 ----------------------- 2301 -- Replicate_Formals -- 2302 ----------------------- 2303 2304 function Replicate_Formals 2305 (Loc : Source_Ptr; 2306 Formals : List_Id) return List_Id 2307 is 2308 New_Formals : constant List_Id := New_List; 2309 Formal : Node_Id; 2310 Param_Type : Node_Id; 2311 2312 begin 2313 Formal := First (Formals); 2314 2315 -- Skip the object parameter when dealing with primitives declared 2316 -- between two views. 2317 2318 if Is_Private_Primitive_Subprogram (Subp_Id) 2319 and then not Has_Controlling_Result (Subp_Id) 2320 then 2321 Next (Formal); 2322 end if; 2323 2324 while Present (Formal) loop 2325 2326 -- Create an explicit copy of the entry parameter 2327 2328 -- When creating the wrapper subprogram for a primitive operation 2329 -- of a protected interface we must construct an equivalent 2330 -- signature to that of the overriding operation. For regular 2331 -- parameters we can just use the type of the formal, but for 2332 -- access to subprogram parameters we need to reanalyze the 2333 -- parameter type to create local entities for the signature of 2334 -- the subprogram type. Using the entities of the overriding 2335 -- subprogram will result in out-of-scope errors in the back-end. 2336 2337 if Nkind (Parameter_Type (Formal)) = N_Access_Definition then 2338 Param_Type := Copy_Separate_Tree (Parameter_Type (Formal)); 2339 else 2340 Param_Type := 2341 New_Occurrence_Of (Etype (Parameter_Type (Formal)), Loc); 2342 end if; 2343 2344 Append_To (New_Formals, 2345 Make_Parameter_Specification (Loc, 2346 Defining_Identifier => 2347 Make_Defining_Identifier (Loc, 2348 Chars => Chars (Defining_Identifier (Formal))), 2349 In_Present => In_Present (Formal), 2350 Out_Present => Out_Present (Formal), 2351 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 2352 Parameter_Type => Param_Type)); 2353 2354 Next (Formal); 2355 end loop; 2356 2357 return New_Formals; 2358 end Replicate_Formals; 2359 2360 -- Local variables 2361 2362 Loc : constant Source_Ptr := Sloc (Subp_Id); 2363 First_Param : Node_Id := Empty; 2364 Iface : Entity_Id; 2365 Iface_Elmt : Elmt_Id; 2366 Iface_Op : Entity_Id; 2367 Iface_Op_Elmt : Elmt_Id; 2368 Overridden_Subp : Entity_Id; 2369 2370 -- Start of processing for Build_Wrapper_Spec 2371 2372 begin 2373 -- No point in building wrappers for untagged concurrent types 2374 2375 pragma Assert (Is_Tagged_Type (Obj_Typ)); 2376 2377 -- Check if this subprogram has a profile that matches some interface 2378 -- primitive. 2379 2380 Check_Synchronized_Overriding (Subp_Id, Overridden_Subp); 2381 2382 if Present (Overridden_Subp) then 2383 First_Param := 2384 First (Parameter_Specifications (Parent (Overridden_Subp))); 2385 2386 -- An entry or a protected procedure can override a routine where the 2387 -- controlling formal is either IN OUT, OUT or is of access-to-variable 2388 -- type. Since the wrapper must have the exact same signature as that of 2389 -- the overridden subprogram, we try to find the overriding candidate 2390 -- and use its controlling formal. 2391 2392 -- Check every implemented interface 2393 2394 elsif Present (Interfaces (Obj_Typ)) then 2395 Iface_Elmt := First_Elmt (Interfaces (Obj_Typ)); 2396 Search : while Present (Iface_Elmt) loop 2397 Iface := Node (Iface_Elmt); 2398 2399 -- Check every interface primitive 2400 2401 if Present (Primitive_Operations (Iface)) then 2402 Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); 2403 while Present (Iface_Op_Elmt) loop 2404 Iface_Op := Node (Iface_Op_Elmt); 2405 2406 -- Ignore predefined primitives 2407 2408 if not Is_Predefined_Dispatching_Operation (Iface_Op) then 2409 Iface_Op := Ultimate_Alias (Iface_Op); 2410 2411 -- The current primitive operation can be overridden by 2412 -- the generated entry wrapper. 2413 2414 if Overriding_Possible (Iface_Op, Subp_Id) then 2415 First_Param := 2416 First (Parameter_Specifications (Parent (Iface_Op))); 2417 2418 exit Search; 2419 end if; 2420 end if; 2421 2422 Next_Elmt (Iface_Op_Elmt); 2423 end loop; 2424 end if; 2425 2426 Next_Elmt (Iface_Elmt); 2427 end loop Search; 2428 end if; 2429 2430 -- Do not generate the wrapper if no interface primitive is covered by 2431 -- the subprogram and it is not a primitive declared between two views 2432 -- (see Process_Full_View). 2433 2434 if No (First_Param) 2435 and then not Is_Private_Primitive_Subprogram (Subp_Id) 2436 then 2437 return Empty; 2438 end if; 2439 2440 declare 2441 Wrapper_Id : constant Entity_Id := 2442 Make_Defining_Identifier (Loc, Chars (Subp_Id)); 2443 New_Formals : List_Id; 2444 Obj_Param : Node_Id; 2445 Obj_Param_Typ : Entity_Id; 2446 2447 begin 2448 -- Minimum decoration is needed to catch the entity in 2449 -- Sem_Ch6.Override_Dispatching_Operation. 2450 2451 if Ekind (Subp_Id) = E_Function then 2452 Set_Ekind (Wrapper_Id, E_Function); 2453 else 2454 Set_Ekind (Wrapper_Id, E_Procedure); 2455 end if; 2456 2457 Set_Is_Primitive_Wrapper (Wrapper_Id); 2458 Set_Wrapped_Entity (Wrapper_Id, Subp_Id); 2459 Set_Is_Private_Primitive (Wrapper_Id, 2460 Is_Private_Primitive_Subprogram (Subp_Id)); 2461 2462 -- Process the formals 2463 2464 New_Formals := Replicate_Formals (Loc, Formals); 2465 2466 -- A function with a controlling result and no first controlling 2467 -- formal needs no additional parameter. 2468 2469 if Has_Controlling_Result (Subp_Id) 2470 and then 2471 (No (First_Formal (Subp_Id)) 2472 or else not Is_Controlling_Formal (First_Formal (Subp_Id))) 2473 then 2474 null; 2475 2476 -- Routine Subp_Id has been found to override an interface primitive. 2477 -- If the interface operation has an access parameter, create a copy 2478 -- of it, with the same null exclusion indicator if present. 2479 2480 elsif Present (First_Param) then 2481 if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then 2482 Obj_Param_Typ := 2483 Make_Access_Definition (Loc, 2484 Subtype_Mark => 2485 New_Occurrence_Of (Obj_Typ, Loc), 2486 Null_Exclusion_Present => 2487 Null_Exclusion_Present (Parameter_Type (First_Param)), 2488 Constant_Present => 2489 Constant_Present (Parameter_Type (First_Param))); 2490 else 2491 Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc); 2492 end if; 2493 2494 Obj_Param := 2495 Make_Parameter_Specification (Loc, 2496 Defining_Identifier => 2497 Make_Defining_Identifier (Loc, 2498 Chars => Name_uO), 2499 In_Present => In_Present (First_Param), 2500 Out_Present => Out_Present (First_Param), 2501 Parameter_Type => Obj_Param_Typ); 2502 2503 Prepend_To (New_Formals, Obj_Param); 2504 2505 -- If we are dealing with a primitive declared between two views, 2506 -- implemented by a synchronized operation, we need to create 2507 -- a default parameter. The mode of the parameter must match that 2508 -- of the primitive operation. 2509 2510 else 2511 pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id)); 2512 2513 Obj_Param := 2514 Make_Parameter_Specification (Loc, 2515 Defining_Identifier => 2516 Make_Defining_Identifier (Loc, Name_uO), 2517 In_Present => 2518 In_Present (Parent (First_Entity (Subp_Id))), 2519 Out_Present => Ekind (Subp_Id) /= E_Function, 2520 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); 2521 2522 Prepend_To (New_Formals, Obj_Param); 2523 end if; 2524 2525 -- Build the final spec. If it is a function with a controlling 2526 -- result, it is a primitive operation of the corresponding 2527 -- record type, so mark the spec accordingly. 2528 2529 if Ekind (Subp_Id) = E_Function then 2530 declare 2531 Res_Def : Node_Id; 2532 2533 begin 2534 if Has_Controlling_Result (Subp_Id) then 2535 Res_Def := 2536 New_Occurrence_Of 2537 (Corresponding_Record_Type (Etype (Subp_Id)), Loc); 2538 else 2539 Res_Def := New_Copy (Result_Definition (Parent (Subp_Id))); 2540 end if; 2541 2542 return 2543 Make_Function_Specification (Loc, 2544 Defining_Unit_Name => Wrapper_Id, 2545 Parameter_Specifications => New_Formals, 2546 Result_Definition => Res_Def); 2547 end; 2548 else 2549 return 2550 Make_Procedure_Specification (Loc, 2551 Defining_Unit_Name => Wrapper_Id, 2552 Parameter_Specifications => New_Formals); 2553 end if; 2554 end; 2555 end Build_Wrapper_Spec; 2556 2557 ------------------------- 2558 -- Build_Wrapper_Specs -- 2559 ------------------------- 2560 2561 procedure Build_Wrapper_Specs 2562 (Loc : Source_Ptr; 2563 Typ : Entity_Id; 2564 N : in out Node_Id) 2565 is 2566 Def : Node_Id; 2567 Rec_Typ : Entity_Id; 2568 procedure Scan_Declarations (L : List_Id); 2569 -- Common processing for visible and private declarations 2570 -- of a protected type. 2571 2572 procedure Scan_Declarations (L : List_Id) is 2573 Decl : Node_Id; 2574 Wrap_Decl : Node_Id; 2575 Wrap_Spec : Node_Id; 2576 2577 begin 2578 if No (L) then 2579 return; 2580 end if; 2581 2582 Decl := First (L); 2583 while Present (Decl) loop 2584 Wrap_Spec := Empty; 2585 2586 if Nkind (Decl) = N_Entry_Declaration 2587 and then Ekind (Defining_Identifier (Decl)) = E_Entry 2588 then 2589 Wrap_Spec := 2590 Build_Wrapper_Spec 2591 (Subp_Id => Defining_Identifier (Decl), 2592 Obj_Typ => Rec_Typ, 2593 Formals => Parameter_Specifications (Decl)); 2594 2595 elsif Nkind (Decl) = N_Subprogram_Declaration then 2596 Wrap_Spec := 2597 Build_Wrapper_Spec 2598 (Subp_Id => Defining_Unit_Name (Specification (Decl)), 2599 Obj_Typ => Rec_Typ, 2600 Formals => 2601 Parameter_Specifications (Specification (Decl))); 2602 end if; 2603 2604 if Present (Wrap_Spec) then 2605 Wrap_Decl := 2606 Make_Subprogram_Declaration (Loc, 2607 Specification => Wrap_Spec); 2608 2609 Insert_After (N, Wrap_Decl); 2610 N := Wrap_Decl; 2611 2612 Analyze (Wrap_Decl); 2613 end if; 2614 2615 Next (Decl); 2616 end loop; 2617 end Scan_Declarations; 2618 2619 -- start of processing for Build_Wrapper_Specs 2620 2621 begin 2622 if Is_Protected_Type (Typ) then 2623 Def := Protected_Definition (Parent (Typ)); 2624 else pragma Assert (Is_Task_Type (Typ)); 2625 Def := Task_Definition (Parent (Typ)); 2626 end if; 2627 2628 Rec_Typ := Corresponding_Record_Type (Typ); 2629 2630 -- Generate wrapper specs for a concurrent type which implements an 2631 -- interface. Operations in both the visible and private parts may 2632 -- implement progenitor operations. 2633 2634 if Present (Interfaces (Rec_Typ)) and then Present (Def) then 2635 Scan_Declarations (Visible_Declarations (Def)); 2636 Scan_Declarations (Private_Declarations (Def)); 2637 end if; 2638 end Build_Wrapper_Specs; 2639 2640 --------------------------- 2641 -- Build_Find_Body_Index -- 2642 --------------------------- 2643 2644 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is 2645 Loc : constant Source_Ptr := Sloc (Typ); 2646 Ent : Entity_Id; 2647 E_Typ : Entity_Id; 2648 Has_F : Boolean := False; 2649 Index : Nat; 2650 If_St : Node_Id := Empty; 2651 Lo : Node_Id; 2652 Hi : Node_Id; 2653 Decls : List_Id := New_List; 2654 Ret : Node_Id := Empty; 2655 Spec : Node_Id; 2656 Siz : Node_Id := Empty; 2657 2658 procedure Add_If_Clause (Expr : Node_Id); 2659 -- Add test for range of current entry 2660 2661 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 2662 -- If a bound of an entry is given by a discriminant, retrieve the 2663 -- actual value of the discriminant from the enclosing object. 2664 2665 ------------------- 2666 -- Add_If_Clause -- 2667 ------------------- 2668 2669 procedure Add_If_Clause (Expr : Node_Id) is 2670 Cond : Node_Id; 2671 Stats : constant List_Id := 2672 New_List ( 2673 Make_Simple_Return_Statement (Loc, 2674 Expression => Make_Integer_Literal (Loc, Index + 1))); 2675 2676 begin 2677 -- Index for current entry body 2678 2679 Index := Index + 1; 2680 2681 -- Compute total length of entry queues so far 2682 2683 if No (Siz) then 2684 Siz := Expr; 2685 else 2686 Siz := 2687 Make_Op_Add (Loc, 2688 Left_Opnd => Siz, 2689 Right_Opnd => Expr); 2690 end if; 2691 2692 Cond := 2693 Make_Op_Le (Loc, 2694 Left_Opnd => Make_Identifier (Loc, Name_uE), 2695 Right_Opnd => Siz); 2696 2697 -- Map entry queue indexes in the range of the current family 2698 -- into the current index, that designates the entry body. 2699 2700 if No (If_St) then 2701 If_St := 2702 Make_Implicit_If_Statement (Typ, 2703 Condition => Cond, 2704 Then_Statements => Stats, 2705 Elsif_Parts => New_List); 2706 Ret := If_St; 2707 2708 else 2709 Append_To (Elsif_Parts (If_St), 2710 Make_Elsif_Part (Loc, 2711 Condition => Cond, 2712 Then_Statements => Stats)); 2713 end if; 2714 end Add_If_Clause; 2715 2716 ------------------------------ 2717 -- Convert_Discriminant_Ref -- 2718 ------------------------------ 2719 2720 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 2721 B : Node_Id; 2722 2723 begin 2724 if Is_Entity_Name (Bound) 2725 and then Ekind (Entity (Bound)) = E_Discriminant 2726 then 2727 B := 2728 Make_Selected_Component (Loc, 2729 Prefix => 2730 Unchecked_Convert_To (Corresponding_Record_Type (Typ), 2731 Make_Explicit_Dereference (Loc, 2732 Make_Identifier (Loc, Name_uObject))), 2733 Selector_Name => Make_Identifier (Loc, Chars (Bound))); 2734 Set_Etype (B, Etype (Entity (Bound))); 2735 else 2736 B := New_Copy_Tree (Bound); 2737 end if; 2738 2739 return B; 2740 end Convert_Discriminant_Ref; 2741 2742 -- Start of processing for Build_Find_Body_Index 2743 2744 begin 2745 Spec := Build_Find_Body_Index_Spec (Typ); 2746 2747 Ent := First_Entity (Typ); 2748 while Present (Ent) loop 2749 if Ekind (Ent) = E_Entry_Family then 2750 Has_F := True; 2751 exit; 2752 end if; 2753 2754 Next_Entity (Ent); 2755 end loop; 2756 2757 if not Has_F then 2758 2759 -- If the protected type has no entry families, there is a one-one 2760 -- correspondence between entry queue and entry body. 2761 2762 Ret := 2763 Make_Simple_Return_Statement (Loc, 2764 Expression => Make_Identifier (Loc, Name_uE)); 2765 2766 else 2767 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate 2768 -- the following: 2769 2770 -- if E <= l1 then return 1; 2771 -- elsif E <= l1 + l2 then return 2; 2772 -- ... 2773 2774 Index := 0; 2775 Siz := Empty; 2776 Ent := First_Entity (Typ); 2777 2778 Add_Object_Pointer (Loc, Typ, Decls); 2779 2780 while Present (Ent) loop 2781 if Ekind (Ent) = E_Entry then 2782 Add_If_Clause (Make_Integer_Literal (Loc, 1)); 2783 2784 elsif Ekind (Ent) = E_Entry_Family then 2785 E_Typ := Entry_Index_Type (Ent); 2786 Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); 2787 Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); 2788 Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False)); 2789 end if; 2790 2791 Next_Entity (Ent); 2792 end loop; 2793 2794 if Index = 1 then 2795 Decls := New_List; 2796 Ret := 2797 Make_Simple_Return_Statement (Loc, 2798 Expression => Make_Integer_Literal (Loc, 1)); 2799 2800 else 2801 pragma Assert (Present (Ret)); 2802 2803 if Nkind (Ret) = N_If_Statement then 2804 2805 -- Ranges are in increasing order, so last one doesn't need 2806 -- guard. 2807 2808 declare 2809 Nod : constant Node_Id := Last (Elsif_Parts (Ret)); 2810 begin 2811 Remove (Nod); 2812 Set_Else_Statements (Ret, Then_Statements (Nod)); 2813 end; 2814 end if; 2815 end if; 2816 end if; 2817 2818 return 2819 Make_Subprogram_Body (Loc, 2820 Specification => Spec, 2821 Declarations => Decls, 2822 Handled_Statement_Sequence => 2823 Make_Handled_Sequence_Of_Statements (Loc, 2824 Statements => New_List (Ret))); 2825 end Build_Find_Body_Index; 2826 2827 -------------------------------- 2828 -- Build_Find_Body_Index_Spec -- 2829 -------------------------------- 2830 2831 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is 2832 Loc : constant Source_Ptr := Sloc (Typ); 2833 Id : constant Entity_Id := 2834 Make_Defining_Identifier (Loc, 2835 Chars => New_External_Name (Chars (Typ), 'F')); 2836 Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO); 2837 Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE); 2838 2839 begin 2840 return 2841 Make_Function_Specification (Loc, 2842 Defining_Unit_Name => Id, 2843 Parameter_Specifications => New_List ( 2844 Make_Parameter_Specification (Loc, 2845 Defining_Identifier => Parm1, 2846 Parameter_Type => 2847 New_Occurrence_Of (RTE (RE_Address), Loc)), 2848 2849 Make_Parameter_Specification (Loc, 2850 Defining_Identifier => Parm2, 2851 Parameter_Type => 2852 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), 2853 2854 Result_Definition => New_Occurrence_Of ( 2855 RTE (RE_Protected_Entry_Index), Loc)); 2856 end Build_Find_Body_Index_Spec; 2857 2858 ----------------------------------------------- 2859 -- Build_Lock_Free_Protected_Subprogram_Body -- 2860 ----------------------------------------------- 2861 2862 function Build_Lock_Free_Protected_Subprogram_Body 2863 (N : Node_Id; 2864 Prot_Typ : Node_Id; 2865 Unprot_Spec : Node_Id) return Node_Id 2866 is 2867 Actuals : constant List_Id := New_List; 2868 Loc : constant Source_Ptr := Sloc (N); 2869 Spec : constant Node_Id := Specification (N); 2870 Unprot_Id : constant Entity_Id := Defining_Unit_Name (Unprot_Spec); 2871 Formal : Node_Id; 2872 Prot_Spec : Node_Id; 2873 Stmt : Node_Id; 2874 2875 begin 2876 -- Create the protected version of the body 2877 2878 Prot_Spec := 2879 Build_Protected_Sub_Specification (N, Prot_Typ, Protected_Mode); 2880 2881 -- Build the actual parameters which appear in the call to the 2882 -- unprotected version of the body. 2883 2884 Formal := First (Parameter_Specifications (Prot_Spec)); 2885 while Present (Formal) loop 2886 Append_To (Actuals, 2887 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 2888 2889 Next (Formal); 2890 end loop; 2891 2892 -- Function case, generate: 2893 -- return <Unprot_Func_Call>; 2894 2895 if Nkind (Spec) = N_Function_Specification then 2896 Stmt := 2897 Make_Simple_Return_Statement (Loc, 2898 Expression => 2899 Make_Function_Call (Loc, 2900 Name => 2901 Make_Identifier (Loc, Chars (Unprot_Id)), 2902 Parameter_Associations => Actuals)); 2903 2904 -- Procedure case, call the unprotected version 2905 2906 else 2907 Stmt := 2908 Make_Procedure_Call_Statement (Loc, 2909 Name => 2910 Make_Identifier (Loc, Chars (Unprot_Id)), 2911 Parameter_Associations => Actuals); 2912 end if; 2913 2914 return 2915 Make_Subprogram_Body (Loc, 2916 Declarations => Empty_List, 2917 Specification => Prot_Spec, 2918 Handled_Statement_Sequence => 2919 Make_Handled_Sequence_Of_Statements (Loc, 2920 Statements => New_List (Stmt))); 2921 end Build_Lock_Free_Protected_Subprogram_Body; 2922 2923 ------------------------------------------------- 2924 -- Build_Lock_Free_Unprotected_Subprogram_Body -- 2925 ------------------------------------------------- 2926 2927 -- Procedures which meet the lock-free implementation requirements and 2928 -- reference a unique scalar component Comp are expanded in the following 2929 -- manner: 2930 2931 -- procedure P (...) is 2932 -- Expected_Comp : constant Comp_Type := 2933 -- Comp_Type 2934 -- (System.Atomic_Primitives.Lock_Free_Read_N 2935 -- (_Object.Comp'Address)); 2936 -- begin 2937 -- loop 2938 -- declare 2939 -- <original declarations before the object renaming declaration 2940 -- of Comp> 2941 -- 2942 -- Desired_Comp : Comp_Type := Expected_Comp; 2943 -- Comp : Comp_Type renames Desired_Comp; 2944 -- 2945 -- <original delarations after the object renaming declaration 2946 -- of Comp> 2947 -- 2948 -- begin 2949 -- <original statements> 2950 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N 2951 -- (_Object.Comp'Address, 2952 -- Interfaces.Unsigned_N (Expected_Comp), 2953 -- Interfaces.Unsigned_N (Desired_Comp)); 2954 -- end; 2955 -- end loop; 2956 -- end P; 2957 2958 -- Each return and raise statement of P is transformed into an atomic 2959 -- status check: 2960 2961 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 2962 -- (_Object.Comp'Address, 2963 -- Interfaces.Unsigned_N (Expected_Comp), 2964 -- Interfaces.Unsigned_N (Desired_Comp)); 2965 -- then 2966 -- <original statement> 2967 -- else 2968 -- goto L0; 2969 -- end if; 2970 2971 -- Functions which meet the lock-free implementation requirements and 2972 -- reference a unique scalar component Comp are expanded in the following 2973 -- manner: 2974 2975 -- function F (...) return ... is 2976 -- <original declarations before the object renaming declaration 2977 -- of Comp> 2978 -- 2979 -- Expected_Comp : constant Comp_Type := 2980 -- Comp_Type 2981 -- (System.Atomic_Primitives.Lock_Free_Read_N 2982 -- (_Object.Comp'Address)); 2983 -- Comp : Comp_Type renames Expected_Comp; 2984 -- 2985 -- <original delarations after the object renaming declaration of 2986 -- Comp> 2987 -- 2988 -- begin 2989 -- <original statements> 2990 -- end F; 2991 2992 function Build_Lock_Free_Unprotected_Subprogram_Body 2993 (N : Node_Id; 2994 Prot_Typ : Node_Id) return Node_Id 2995 is 2996 function Referenced_Component (N : Node_Id) return Entity_Id; 2997 -- Subprograms which meet the lock-free implementation criteria are 2998 -- allowed to reference only one unique component. Return the prival 2999 -- of the said component. 3000 3001 -------------------------- 3002 -- Referenced_Component -- 3003 -------------------------- 3004 3005 function Referenced_Component (N : Node_Id) return Entity_Id is 3006 Comp : Entity_Id; 3007 Decl : Node_Id; 3008 Source_Comp : Entity_Id := Empty; 3009 3010 begin 3011 -- Find the unique source component which N references in its 3012 -- statements. 3013 3014 for Index in 1 .. Lock_Free_Subprogram_Table.Last loop 3015 declare 3016 Element : Lock_Free_Subprogram renames 3017 Lock_Free_Subprogram_Table.Table (Index); 3018 begin 3019 if Element.Sub_Body = N then 3020 Source_Comp := Element.Comp_Id; 3021 exit; 3022 end if; 3023 end; 3024 end loop; 3025 3026 if No (Source_Comp) then 3027 return Empty; 3028 end if; 3029 3030 -- Find the prival which corresponds to the source component within 3031 -- the declarations of N. 3032 3033 Decl := First (Declarations (N)); 3034 while Present (Decl) loop 3035 3036 -- Privals appear as object renamings 3037 3038 if Nkind (Decl) = N_Object_Renaming_Declaration then 3039 Comp := Defining_Identifier (Decl); 3040 3041 if Present (Prival_Link (Comp)) 3042 and then Prival_Link (Comp) = Source_Comp 3043 then 3044 return Comp; 3045 end if; 3046 end if; 3047 3048 Next (Decl); 3049 end loop; 3050 3051 return Empty; 3052 end Referenced_Component; 3053 3054 -- Local variables 3055 3056 Comp : constant Entity_Id := Referenced_Component (N); 3057 Loc : constant Source_Ptr := Sloc (N); 3058 Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N); 3059 Decls : List_Id := Declarations (N); 3060 3061 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body 3062 3063 begin 3064 -- Add renamings for the protection object, discriminals, privals, and 3065 -- the entry index constant for use by debugger. 3066 3067 Debug_Private_Data_Declarations (Decls); 3068 3069 -- Perform the lock-free expansion when the subprogram references a 3070 -- protected component. 3071 3072 if Present (Comp) then 3073 Protected_Component_Ref : declare 3074 Comp_Decl : constant Node_Id := Parent (Comp); 3075 Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl); 3076 Comp_Type : constant Entity_Id := Etype (Comp); 3077 3078 Is_Procedure : constant Boolean := 3079 Ekind (Corresponding_Spec (N)) = E_Procedure; 3080 -- Indicates if N is a protected procedure body 3081 3082 Block_Decls : List_Id := No_List; 3083 Try_Write : Entity_Id; 3084 Desired_Comp : Entity_Id; 3085 Decl : Node_Id; 3086 Label : Node_Id; 3087 Label_Id : Entity_Id := Empty; 3088 Read : Entity_Id; 3089 Expected_Comp : Entity_Id; 3090 Stmt : Node_Id; 3091 Stmts : List_Id := 3092 New_Copy_List (Statements (Hand_Stmt_Seq)); 3093 Typ_Size : Int; 3094 Unsigned : Entity_Id; 3095 3096 function Process_Node (N : Node_Id) return Traverse_Result; 3097 -- Transform a single node if it is a return statement, a raise 3098 -- statement or a reference to Comp. 3099 3100 procedure Process_Stmts (Stmts : List_Id); 3101 -- Given a statement sequence Stmts, wrap any return or raise 3102 -- statements in the following manner: 3103 -- 3104 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3105 -- (_Object.Comp'Address, 3106 -- Interfaces.Unsigned_N (Expected_Comp), 3107 -- Interfaces.Unsigned_N (Desired_Comp)) 3108 -- then 3109 -- <Stmt>; 3110 -- else 3111 -- goto L0; 3112 -- end if; 3113 3114 ------------------ 3115 -- Process_Node -- 3116 ------------------ 3117 3118 function Process_Node (N : Node_Id) return Traverse_Result is 3119 3120 procedure Wrap_Statement (Stmt : Node_Id); 3121 -- Wrap an arbitrary statement inside an if statement where the 3122 -- condition does an atomic check on the state of the object. 3123 3124 -------------------- 3125 -- Wrap_Statement -- 3126 -------------------- 3127 3128 procedure Wrap_Statement (Stmt : Node_Id) is 3129 begin 3130 -- The first time through, create the declaration of a label 3131 -- which is used to skip the remainder of source statements 3132 -- if the state of the object has changed. 3133 3134 if No (Label_Id) then 3135 Label_Id := 3136 Make_Identifier (Loc, New_External_Name ('L', 0)); 3137 Set_Entity (Label_Id, 3138 Make_Defining_Identifier (Loc, Chars (Label_Id))); 3139 end if; 3140 3141 -- Generate: 3142 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3143 -- (_Object.Comp'Address, 3144 -- Interfaces.Unsigned_N (Expected_Comp), 3145 -- Interfaces.Unsigned_N (Desired_Comp)) 3146 -- then 3147 -- <Stmt>; 3148 -- else 3149 -- goto L0; 3150 -- end if; 3151 3152 Rewrite (Stmt, 3153 Make_Implicit_If_Statement (N, 3154 Condition => 3155 Make_Function_Call (Loc, 3156 Name => 3157 New_Occurrence_Of (Try_Write, Loc), 3158 Parameter_Associations => New_List ( 3159 Make_Attribute_Reference (Loc, 3160 Prefix => Relocate_Node (Comp_Sel_Nam), 3161 Attribute_Name => Name_Address), 3162 3163 Unchecked_Convert_To (Unsigned, 3164 New_Occurrence_Of (Expected_Comp, Loc)), 3165 3166 Unchecked_Convert_To (Unsigned, 3167 New_Occurrence_Of (Desired_Comp, Loc)))), 3168 3169 Then_Statements => New_List (Relocate_Node (Stmt)), 3170 3171 Else_Statements => New_List ( 3172 Make_Goto_Statement (Loc, 3173 Name => 3174 New_Occurrence_Of (Entity (Label_Id), Loc))))); 3175 end Wrap_Statement; 3176 3177 -- Start of processing for Process_Node 3178 3179 begin 3180 -- Wrap each return and raise statement that appear inside a 3181 -- procedure. Skip the last return statement which is added by 3182 -- default since it is transformed into an exit statement. 3183 3184 if Is_Procedure 3185 and then ((Nkind (N) = N_Simple_Return_Statement 3186 and then N /= Last (Stmts)) 3187 or else Nkind (N) = N_Extended_Return_Statement 3188 or else (Nkind (N) in 3189 N_Raise_xxx_Error | N_Raise_Statement 3190 and then Comes_From_Source (N))) 3191 then 3192 Wrap_Statement (N); 3193 return Skip; 3194 end if; 3195 3196 -- Force reanalysis 3197 3198 Set_Analyzed (N, False); 3199 3200 return OK; 3201 end Process_Node; 3202 3203 procedure Process_Nodes is new Traverse_Proc (Process_Node); 3204 3205 ------------------- 3206 -- Process_Stmts -- 3207 ------------------- 3208 3209 procedure Process_Stmts (Stmts : List_Id) is 3210 Stmt : Node_Id; 3211 begin 3212 Stmt := First (Stmts); 3213 while Present (Stmt) loop 3214 Process_Nodes (Stmt); 3215 Next (Stmt); 3216 end loop; 3217 end Process_Stmts; 3218 3219 -- Start of processing for Protected_Component_Ref 3220 3221 begin 3222 -- Get the type size 3223 3224 if Known_Static_Esize (Comp_Type) then 3225 Typ_Size := UI_To_Int (Esize (Comp_Type)); 3226 3227 -- If the Esize (Object_Size) is unknown at compile time, look at 3228 -- the RM_Size (Value_Size) since it may have been set by an 3229 -- explicit representation clause. 3230 3231 elsif Known_Static_RM_Size (Comp_Type) then 3232 Typ_Size := UI_To_Int (RM_Size (Comp_Type)); 3233 3234 -- Should not happen since this has already been checked in 3235 -- Allows_Lock_Free_Implementation (see Sem_Ch9). 3236 3237 else 3238 raise Program_Error; 3239 end if; 3240 3241 -- Retrieve all relevant atomic routines and types 3242 3243 case Typ_Size is 3244 when 8 => 3245 Try_Write := RTE (RE_Lock_Free_Try_Write_8); 3246 Read := RTE (RE_Lock_Free_Read_8); 3247 Unsigned := RTE (RE_Uint8); 3248 3249 when 16 => 3250 Try_Write := RTE (RE_Lock_Free_Try_Write_16); 3251 Read := RTE (RE_Lock_Free_Read_16); 3252 Unsigned := RTE (RE_Uint16); 3253 3254 when 32 => 3255 Try_Write := RTE (RE_Lock_Free_Try_Write_32); 3256 Read := RTE (RE_Lock_Free_Read_32); 3257 Unsigned := RTE (RE_Uint32); 3258 3259 when 64 => 3260 Try_Write := RTE (RE_Lock_Free_Try_Write_64); 3261 Read := RTE (RE_Lock_Free_Read_64); 3262 Unsigned := RTE (RE_Uint64); 3263 3264 when others => 3265 raise Program_Error; 3266 end case; 3267 3268 -- Generate: 3269 -- Expected_Comp : constant Comp_Type := 3270 -- Comp_Type 3271 -- (System.Atomic_Primitives.Lock_Free_Read_N 3272 -- (_Object.Comp'Address)); 3273 3274 Expected_Comp := 3275 Make_Defining_Identifier (Loc, 3276 New_External_Name (Chars (Comp), Suffix => "_saved")); 3277 3278 Decl := 3279 Make_Object_Declaration (Loc, 3280 Defining_Identifier => Expected_Comp, 3281 Object_Definition => New_Occurrence_Of (Comp_Type, Loc), 3282 Constant_Present => True, 3283 Expression => 3284 Unchecked_Convert_To (Comp_Type, 3285 Make_Function_Call (Loc, 3286 Name => New_Occurrence_Of (Read, Loc), 3287 Parameter_Associations => New_List ( 3288 Make_Attribute_Reference (Loc, 3289 Prefix => Relocate_Node (Comp_Sel_Nam), 3290 Attribute_Name => Name_Address))))); 3291 3292 -- Protected procedures 3293 3294 if Is_Procedure then 3295 -- Move the original declarations inside the generated block 3296 3297 Block_Decls := Decls; 3298 3299 -- Reset the declarations list of the protected procedure to 3300 -- contain only Decl. 3301 3302 Decls := New_List (Decl); 3303 3304 -- Generate: 3305 -- Desired_Comp : Comp_Type := Expected_Comp; 3306 3307 Desired_Comp := 3308 Make_Defining_Identifier (Loc, 3309 New_External_Name (Chars (Comp), Suffix => "_current")); 3310 3311 -- Insert the declarations of Expected_Comp and Desired_Comp in 3312 -- the block declarations right before the renaming of the 3313 -- protected component. 3314 3315 Insert_Before (Comp_Decl, 3316 Make_Object_Declaration (Loc, 3317 Defining_Identifier => Desired_Comp, 3318 Object_Definition => New_Occurrence_Of (Comp_Type, Loc), 3319 Expression => 3320 New_Occurrence_Of (Expected_Comp, Loc))); 3321 3322 -- Protected function 3323 3324 else 3325 Desired_Comp := Expected_Comp; 3326 3327 -- Insert the declaration of Expected_Comp in the function 3328 -- declarations right before the renaming of the protected 3329 -- component. 3330 3331 Insert_Before (Comp_Decl, Decl); 3332 end if; 3333 3334 -- Rewrite the protected component renaming declaration to be a 3335 -- renaming of Desired_Comp. 3336 3337 -- Generate: 3338 -- Comp : Comp_Type renames Desired_Comp; 3339 3340 Rewrite (Comp_Decl, 3341 Make_Object_Renaming_Declaration (Loc, 3342 Defining_Identifier => 3343 Defining_Identifier (Comp_Decl), 3344 Subtype_Mark => 3345 New_Occurrence_Of (Comp_Type, Loc), 3346 Name => 3347 New_Occurrence_Of (Desired_Comp, Loc))); 3348 3349 -- Wrap any return or raise statements in Stmts in same the manner 3350 -- described in Process_Stmts. 3351 3352 Process_Stmts (Stmts); 3353 3354 -- Generate: 3355 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N 3356 -- (_Object.Comp'Address, 3357 -- Interfaces.Unsigned_N (Expected_Comp), 3358 -- Interfaces.Unsigned_N (Desired_Comp)) 3359 3360 if Is_Procedure then 3361 Stmt := 3362 Make_Exit_Statement (Loc, 3363 Condition => 3364 Make_Function_Call (Loc, 3365 Name => 3366 New_Occurrence_Of (Try_Write, Loc), 3367 Parameter_Associations => New_List ( 3368 Make_Attribute_Reference (Loc, 3369 Prefix => Relocate_Node (Comp_Sel_Nam), 3370 Attribute_Name => Name_Address), 3371 3372 Unchecked_Convert_To (Unsigned, 3373 New_Occurrence_Of (Expected_Comp, Loc)), 3374 3375 Unchecked_Convert_To (Unsigned, 3376 New_Occurrence_Of (Desired_Comp, Loc))))); 3377 3378 -- Small optimization: transform the default return statement 3379 -- of a procedure into the atomic exit statement. 3380 3381 if Nkind (Last (Stmts)) = N_Simple_Return_Statement then 3382 Rewrite (Last (Stmts), Stmt); 3383 else 3384 Append_To (Stmts, Stmt); 3385 end if; 3386 end if; 3387 3388 -- Create the declaration of the label used to skip the rest of 3389 -- the source statements when the object state changes. 3390 3391 if Present (Label_Id) then 3392 Label := Make_Label (Loc, Label_Id); 3393 Append_To (Decls, 3394 Make_Implicit_Label_Declaration (Loc, 3395 Defining_Identifier => Entity (Label_Id), 3396 Label_Construct => Label)); 3397 Append_To (Stmts, Label); 3398 end if; 3399 3400 -- Generate: 3401 -- loop 3402 -- declare 3403 -- <Decls> 3404 -- begin 3405 -- <Stmts> 3406 -- end; 3407 -- end loop; 3408 3409 if Is_Procedure then 3410 Stmts := 3411 New_List ( 3412 Make_Loop_Statement (Loc, 3413 Statements => New_List ( 3414 Make_Block_Statement (Loc, 3415 Declarations => Block_Decls, 3416 Handled_Statement_Sequence => 3417 Make_Handled_Sequence_Of_Statements (Loc, 3418 Statements => Stmts))), 3419 End_Label => Empty)); 3420 end if; 3421 3422 Hand_Stmt_Seq := 3423 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts); 3424 end Protected_Component_Ref; 3425 end if; 3426 3427 -- Make an unprotected version of the subprogram for use within the same 3428 -- object, with new name and extra parameter representing the object. 3429 3430 return 3431 Make_Subprogram_Body (Loc, 3432 Specification => 3433 Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode), 3434 Declarations => Decls, 3435 Handled_Statement_Sequence => Hand_Stmt_Seq); 3436 end Build_Lock_Free_Unprotected_Subprogram_Body; 3437 3438 ------------------------- 3439 -- Build_Master_Entity -- 3440 ------------------------- 3441 3442 procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is 3443 Loc : constant Source_Ptr := Sloc (Obj_Or_Typ); 3444 Context : Node_Id; 3445 Context_Id : Entity_Id; 3446 Decl : Node_Id; 3447 Decls : List_Id; 3448 Par : Node_Id; 3449 3450 begin 3451 -- No action needed if the run-time has no tasking support 3452 3453 if Global_No_Tasking then 3454 return; 3455 end if; 3456 3457 if Is_Itype (Obj_Or_Typ) then 3458 Par := Associated_Node_For_Itype (Obj_Or_Typ); 3459 else 3460 Par := Parent (Obj_Or_Typ); 3461 end if; 3462 3463 -- For transient scopes check if the master entity is already defined 3464 3465 if Is_Type (Obj_Or_Typ) 3466 and then Ekind (Scope (Obj_Or_Typ)) = E_Block 3467 and then Is_Internal (Scope (Obj_Or_Typ)) 3468 then 3469 declare 3470 Master_Scope : constant Entity_Id := 3471 Find_Master_Scope (Obj_Or_Typ); 3472 begin 3473 if Has_Master_Entity (Master_Scope) 3474 or else Is_Finalizer (Master_Scope) 3475 then 3476 return; 3477 end if; 3478 3479 if Present (Current_Entity_In_Scope (Name_uMaster)) then 3480 return; 3481 end if; 3482 end; 3483 end if; 3484 3485 -- When creating a master for a record component which is either a task 3486 -- or access-to-task, the enclosing record is the master scope and the 3487 -- proper insertion point is the component list. 3488 3489 if Is_Record_Type (Current_Scope) then 3490 Context := Par; 3491 Context_Id := Current_Scope; 3492 Decls := List_Containing (Context); 3493 3494 -- Default case for object declarations and access types. Note that the 3495 -- context is updated to the nearest enclosing body, block, package, or 3496 -- return statement. 3497 3498 else 3499 Find_Enclosing_Context (Par, Context, Context_Id, Decls); 3500 end if; 3501 3502 -- Nothing to do if the context already has a master; internally built 3503 -- finalizers don't need a master. 3504 3505 if Has_Master_Entity (Context_Id) 3506 or else Is_Finalizer (Context_Id) 3507 then 3508 return; 3509 end if; 3510 3511 Decl := Build_Master_Declaration (Loc); 3512 3513 -- The master is inserted at the start of the declarative list of the 3514 -- context. 3515 3516 Prepend_To (Decls, Decl); 3517 3518 -- In certain cases where transient scopes are involved, the immediate 3519 -- scope is not always the proper master scope. Ensure that the master 3520 -- declaration and entity appear in the same context. 3521 3522 if Context_Id /= Current_Scope then 3523 Push_Scope (Context_Id); 3524 Analyze (Decl); 3525 Pop_Scope; 3526 else 3527 Analyze (Decl); 3528 end if; 3529 3530 -- Mark the enclosing scope and its associated construct as being task 3531 -- masters. 3532 3533 Set_Has_Master_Entity (Context_Id); 3534 3535 while Present (Context) 3536 and then Nkind (Context) /= N_Compilation_Unit 3537 loop 3538 if Nkind (Context) in 3539 N_Block_Statement | N_Subprogram_Body | N_Task_Body 3540 then 3541 Set_Is_Task_Master (Context); 3542 exit; 3543 3544 elsif Nkind (Parent (Context)) = N_Subunit then 3545 Context := Corresponding_Stub (Parent (Context)); 3546 end if; 3547 3548 Context := Parent (Context); 3549 end loop; 3550 end Build_Master_Entity; 3551 3552 --------------------------- 3553 -- Build_Master_Renaming -- 3554 --------------------------- 3555 3556 procedure Build_Master_Renaming 3557 (Ptr_Typ : Entity_Id; 3558 Ins_Nod : Node_Id := Empty) 3559 is 3560 Loc : constant Source_Ptr := Sloc (Ptr_Typ); 3561 Context : Node_Id; 3562 Master_Decl : Node_Id; 3563 Master_Id : Entity_Id; 3564 3565 begin 3566 -- No action needed if the run-time has no tasking support 3567 3568 if Global_No_Tasking then 3569 return; 3570 end if; 3571 3572 -- Determine the proper context to insert the master renaming 3573 3574 if Present (Ins_Nod) then 3575 Context := Ins_Nod; 3576 3577 elsif Is_Itype (Ptr_Typ) then 3578 Context := Associated_Node_For_Itype (Ptr_Typ); 3579 3580 -- When the context references a discriminant or a component of a 3581 -- private type and we are processing declarations in the private 3582 -- part of the enclosing package, we must insert the master renaming 3583 -- before the full declaration of the private type; otherwise the 3584 -- master renaming would be inserted in the public part of the 3585 -- package (and hence before the declaration of _master). 3586 3587 if In_Private_Part (Current_Scope) then 3588 declare 3589 Ctx : Node_Id := Context; 3590 3591 begin 3592 if Nkind (Context) = N_Discriminant_Specification then 3593 Ctx := Parent (Ctx); 3594 else 3595 while Nkind (Ctx) in 3596 N_Component_Declaration | N_Component_List 3597 loop 3598 Ctx := Parent (Ctx); 3599 end loop; 3600 end if; 3601 3602 if Nkind (Ctx) in N_Private_Type_Declaration 3603 | N_Private_Extension_Declaration 3604 then 3605 Context := Parent (Full_View (Defining_Identifier (Ctx))); 3606 end if; 3607 end; 3608 end if; 3609 3610 else 3611 Context := Parent (Ptr_Typ); 3612 end if; 3613 3614 -- Generate: 3615 -- <Ptr_Typ>M : Master_Id renames _Master; 3616 -- and add a numeric suffix to the name to ensure that it is 3617 -- unique in case other access types in nested constructs 3618 -- are homonyms of this one. 3619 3620 Master_Id := 3621 Make_Defining_Identifier (Loc, 3622 New_External_Name (Chars (Ptr_Typ), 'M', -1)); 3623 3624 Master_Decl := 3625 Make_Object_Renaming_Declaration (Loc, 3626 Defining_Identifier => Master_Id, 3627 Subtype_Mark => New_Occurrence_Of (RTE (RE_Master_Id), Loc), 3628 Name => Make_Identifier (Loc, Name_uMaster)); 3629 3630 Insert_Action (Context, Master_Decl); 3631 3632 -- The renamed master now services the access type 3633 3634 Set_Master_Id (Ptr_Typ, Master_Id); 3635 end Build_Master_Renaming; 3636 3637 --------------------------- 3638 -- Build_Protected_Entry -- 3639 --------------------------- 3640 3641 function Build_Protected_Entry 3642 (N : Node_Id; 3643 Ent : Entity_Id; 3644 Pid : Node_Id) return Node_Id 3645 is 3646 Bod_Decls : constant List_Id := New_List; 3647 Decls : constant List_Id := Declarations (N); 3648 End_Lab : constant Node_Id := 3649 End_Label (Handled_Statement_Sequence (N)); 3650 End_Loc : constant Source_Ptr := 3651 Sloc (Last (Statements (Handled_Statement_Sequence (N)))); 3652 -- Used for the generated call to Complete_Entry_Body 3653 3654 Loc : constant Source_Ptr := Sloc (N); 3655 3656 Bod_Id : Entity_Id; 3657 Bod_Spec : Node_Id; 3658 Bod_Stmts : List_Id; 3659 Complete : Node_Id; 3660 Ohandle : Node_Id; 3661 Proc_Body : Node_Id; 3662 3663 EH_Loc : Source_Ptr; 3664 -- Used for the exception handler, inserted at end of the body 3665 3666 begin 3667 -- Set the source location on the exception handler only when debugging 3668 -- the expanded code (see Make_Implicit_Exception_Handler). 3669 3670 if Debug_Generated_Code then 3671 EH_Loc := End_Loc; 3672 3673 -- Otherwise the inserted code should not be visible to the debugger 3674 3675 else 3676 EH_Loc := No_Location; 3677 end if; 3678 3679 Bod_Id := 3680 Make_Defining_Identifier (Loc, 3681 Chars => Chars (Protected_Body_Subprogram (Ent))); 3682 Bod_Spec := Build_Protected_Entry_Specification (Loc, Bod_Id, Empty); 3683 3684 -- Add the following declarations: 3685 3686 -- type poVP is access poV; 3687 -- _object : poVP := poVP (_O); 3688 3689 -- where _O is the formal parameter associated with the concurrent 3690 -- object. These declarations are needed for Complete_Entry_Body. 3691 3692 Add_Object_Pointer (Loc, Pid, Bod_Decls); 3693 3694 -- Add renamings for all formals, the Protection object, discriminals, 3695 -- privals and the entry index constant for use by debugger. 3696 3697 Add_Formal_Renamings (Bod_Spec, Bod_Decls, Ent, Loc); 3698 Debug_Private_Data_Declarations (Decls); 3699 3700 -- Put the declarations and the statements from the entry 3701 3702 Bod_Stmts := 3703 New_List ( 3704 Make_Block_Statement (Loc, 3705 Declarations => Decls, 3706 Handled_Statement_Sequence => Handled_Statement_Sequence (N))); 3707 3708 -- Analyze now and reset scopes for declarations so that Scope fields 3709 -- currently denoting the entry will now denote the block scope, and 3710 -- the block's scope will be set to the new procedure entity. 3711 3712 Analyze_Statements (Bod_Stmts); 3713 3714 Set_Scope (Entity (Identifier (First (Bod_Stmts))), Bod_Id); 3715 3716 Reset_Scopes_To 3717 (First (Bod_Stmts), Entity (Identifier (First (Bod_Stmts)))); 3718 3719 case Corresponding_Runtime_Package (Pid) is 3720 when System_Tasking_Protected_Objects_Entries => 3721 Append_To (Bod_Stmts, 3722 Make_Procedure_Call_Statement (End_Loc, 3723 Name => 3724 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc), 3725 Parameter_Associations => New_List ( 3726 Make_Attribute_Reference (End_Loc, 3727 Prefix => 3728 Make_Selected_Component (End_Loc, 3729 Prefix => 3730 Make_Identifier (End_Loc, Name_uObject), 3731 Selector_Name => 3732 Make_Identifier (End_Loc, Name_uObject)), 3733 Attribute_Name => Name_Unchecked_Access)))); 3734 3735 when System_Tasking_Protected_Objects_Single_Entry => 3736 3737 -- Historically, a call to Complete_Single_Entry_Body was 3738 -- inserted, but it was a null procedure. 3739 3740 null; 3741 3742 when others => 3743 raise Program_Error; 3744 end case; 3745 3746 -- When exceptions cannot be propagated, we never need to call 3747 -- Exception_Complete_Entry_Body. 3748 3749 if No_Exception_Handlers_Set then 3750 return 3751 Make_Subprogram_Body (Loc, 3752 Specification => Bod_Spec, 3753 Declarations => Bod_Decls, 3754 Handled_Statement_Sequence => 3755 Make_Handled_Sequence_Of_Statements (Loc, 3756 Statements => Bod_Stmts, 3757 End_Label => End_Lab)); 3758 3759 else 3760 Ohandle := Make_Others_Choice (Loc); 3761 Set_All_Others (Ohandle); 3762 3763 case Corresponding_Runtime_Package (Pid) is 3764 when System_Tasking_Protected_Objects_Entries => 3765 Complete := 3766 New_Occurrence_Of 3767 (RTE (RE_Exceptional_Complete_Entry_Body), Loc); 3768 3769 when System_Tasking_Protected_Objects_Single_Entry => 3770 Complete := 3771 New_Occurrence_Of 3772 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); 3773 3774 when others => 3775 raise Program_Error; 3776 end case; 3777 3778 -- Establish link between subprogram body entity and source entry 3779 3780 Set_Corresponding_Protected_Entry (Bod_Id, Ent); 3781 3782 -- Create body of entry procedure. The renaming declarations are 3783 -- placed ahead of the block that contains the actual entry body. 3784 3785 Proc_Body := 3786 Make_Subprogram_Body (Loc, 3787 Specification => Bod_Spec, 3788 Declarations => Bod_Decls, 3789 Handled_Statement_Sequence => 3790 Make_Handled_Sequence_Of_Statements (Loc, 3791 Statements => Bod_Stmts, 3792 End_Label => End_Lab, 3793 Exception_Handlers => New_List ( 3794 Make_Implicit_Exception_Handler (EH_Loc, 3795 Exception_Choices => New_List (Ohandle), 3796 3797 Statements => New_List ( 3798 Make_Procedure_Call_Statement (EH_Loc, 3799 Name => Complete, 3800 Parameter_Associations => New_List ( 3801 Make_Attribute_Reference (EH_Loc, 3802 Prefix => 3803 Make_Selected_Component (EH_Loc, 3804 Prefix => 3805 Make_Identifier (EH_Loc, Name_uObject), 3806 Selector_Name => 3807 Make_Identifier (EH_Loc, Name_uObject)), 3808 Attribute_Name => Name_Unchecked_Access), 3809 3810 Make_Function_Call (EH_Loc, 3811 Name => 3812 New_Occurrence_Of 3813 (RTE (RE_Get_GNAT_Exception), Loc))))))))); 3814 3815 Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent)); 3816 return Proc_Body; 3817 end if; 3818 end Build_Protected_Entry; 3819 3820 ----------------------------------------- 3821 -- Build_Protected_Entry_Specification -- 3822 ----------------------------------------- 3823 3824 function Build_Protected_Entry_Specification 3825 (Loc : Source_Ptr; 3826 Def_Id : Entity_Id; 3827 Ent_Id : Entity_Id) return Node_Id 3828 is 3829 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP); 3830 3831 begin 3832 Set_Debug_Info_Needed (Def_Id); 3833 3834 if Present (Ent_Id) then 3835 Append_Elmt (P, Accept_Address (Ent_Id)); 3836 end if; 3837 3838 return 3839 Make_Procedure_Specification (Loc, 3840 Defining_Unit_Name => Def_Id, 3841 Parameter_Specifications => New_List ( 3842 Make_Parameter_Specification (Loc, 3843 Defining_Identifier => 3844 Make_Defining_Identifier (Loc, Name_uO), 3845 Parameter_Type => 3846 New_Occurrence_Of (RTE (RE_Address), Loc)), 3847 3848 Make_Parameter_Specification (Loc, 3849 Defining_Identifier => P, 3850 Parameter_Type => 3851 New_Occurrence_Of (RTE (RE_Address), Loc)), 3852 3853 Make_Parameter_Specification (Loc, 3854 Defining_Identifier => 3855 Make_Defining_Identifier (Loc, Name_uE), 3856 Parameter_Type => 3857 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)))); 3858 end Build_Protected_Entry_Specification; 3859 3860 -------------------------- 3861 -- Build_Protected_Spec -- 3862 -------------------------- 3863 3864 function Build_Protected_Spec 3865 (N : Node_Id; 3866 Obj_Type : Entity_Id; 3867 Ident : Entity_Id; 3868 Unprotected : Boolean := False) return List_Id 3869 is 3870 Loc : constant Source_Ptr := Sloc (N); 3871 Decl : Node_Id; 3872 Formal : Entity_Id; 3873 New_Plist : List_Id; 3874 New_Param : Node_Id; 3875 3876 begin 3877 New_Plist := New_List; 3878 3879 Formal := First_Formal (Ident); 3880 while Present (Formal) loop 3881 New_Param := 3882 Make_Parameter_Specification (Loc, 3883 Defining_Identifier => 3884 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 3885 Aliased_Present => Aliased_Present (Parent (Formal)), 3886 In_Present => In_Present (Parent (Formal)), 3887 Out_Present => Out_Present (Parent (Formal)), 3888 Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc)); 3889 3890 if Unprotected then 3891 Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); 3892 Set_Ekind (Defining_Identifier (New_Param), Ekind (Formal)); 3893 end if; 3894 3895 Append (New_Param, New_Plist); 3896 Next_Formal (Formal); 3897 end loop; 3898 3899 -- If the subprogram is a procedure and the context is not an access 3900 -- to protected subprogram, the parameter is in-out. Otherwise it is 3901 -- an in parameter. 3902 3903 Decl := 3904 Make_Parameter_Specification (Loc, 3905 Defining_Identifier => 3906 Make_Defining_Identifier (Loc, Name_uObject), 3907 In_Present => True, 3908 Out_Present => 3909 (Etype (Ident) = Standard_Void_Type 3910 and then not Is_RTE (Obj_Type, RE_Address)), 3911 Parameter_Type => 3912 New_Occurrence_Of (Obj_Type, Loc)); 3913 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 3914 Prepend_To (New_Plist, Decl); 3915 3916 return New_Plist; 3917 end Build_Protected_Spec; 3918 3919 --------------------------------------- 3920 -- Build_Protected_Sub_Specification -- 3921 --------------------------------------- 3922 3923 function Build_Protected_Sub_Specification 3924 (N : Node_Id; 3925 Prot_Typ : Entity_Id; 3926 Mode : Subprogram_Protection_Mode) return Node_Id 3927 is 3928 Loc : constant Source_Ptr := Sloc (N); 3929 Decl : Node_Id; 3930 Def_Id : Entity_Id; 3931 New_Id : Entity_Id; 3932 New_Plist : List_Id; 3933 New_Spec : Node_Id; 3934 3935 Append_Chr : constant array (Subprogram_Protection_Mode) of Character := 3936 (Dispatching_Mode => ' ', 3937 Protected_Mode => 'P', 3938 Unprotected_Mode => 'N'); 3939 3940 begin 3941 if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body 3942 then 3943 Decl := Unit_Declaration_Node (Corresponding_Spec (N)); 3944 else 3945 Decl := N; 3946 end if; 3947 3948 Def_Id := Defining_Unit_Name (Specification (Decl)); 3949 3950 New_Plist := 3951 Build_Protected_Spec 3952 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id, 3953 Mode = Unprotected_Mode); 3954 New_Id := 3955 Make_Defining_Identifier (Loc, 3956 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); 3957 3958 -- Reference the original nondispatching subprogram since the analysis 3959 -- of the object.operation notation may need its original name (see 3960 -- Sem_Ch4.Names_Match). 3961 3962 if Mode = Dispatching_Mode then 3963 Set_Ekind (New_Id, Ekind (Def_Id)); 3964 Set_Original_Protected_Subprogram (New_Id, Def_Id); 3965 end if; 3966 3967 -- Link the protected or unprotected version to the original subprogram 3968 -- it emulates. 3969 3970 Set_Ekind (New_Id, Ekind (Def_Id)); 3971 Set_Protected_Subprogram (New_Id, Def_Id); 3972 3973 -- The unprotected operation carries the user code, and debugging 3974 -- information must be generated for it, even though this spec does 3975 -- not come from source. It is also convenient to allow gdb to step 3976 -- into the protected operation, even though it only contains lock/ 3977 -- unlock calls. 3978 3979 Set_Debug_Info_Needed (New_Id); 3980 3981 -- If a pragma Eliminate applies to the source entity, the internal 3982 -- subprograms will be eliminated as well. 3983 3984 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id)); 3985 3986 -- It seems we should set Has_Nested_Subprogram here, but instead we 3987 -- currently set it in Expand_N_Protected_Body, because the entity 3988 -- created here isn't the one that Corresponding_Spec of the body 3989 -- will later be set to, and that's the entity where it's needed. ??? 3990 3991 Set_Has_Nested_Subprogram (New_Id, Has_Nested_Subprogram (Def_Id)); 3992 3993 if Nkind (Specification (Decl)) = N_Procedure_Specification then 3994 New_Spec := 3995 Make_Procedure_Specification (Loc, 3996 Defining_Unit_Name => New_Id, 3997 Parameter_Specifications => New_Plist); 3998 3999 -- Create a new specification for the anonymous subprogram type 4000 4001 else 4002 New_Spec := 4003 Make_Function_Specification (Loc, 4004 Defining_Unit_Name => New_Id, 4005 Parameter_Specifications => New_Plist, 4006 Result_Definition => 4007 Copy_Result_Type (Result_Definition (Specification (Decl)))); 4008 4009 Set_Return_Present (Defining_Unit_Name (New_Spec)); 4010 end if; 4011 4012 return New_Spec; 4013 end Build_Protected_Sub_Specification; 4014 4015 ------------------------------------- 4016 -- Build_Protected_Subprogram_Body -- 4017 ------------------------------------- 4018 4019 function Build_Protected_Subprogram_Body 4020 (N : Node_Id; 4021 Pid : Node_Id; 4022 N_Op_Spec : Node_Id) return Node_Id 4023 is 4024 Exc_Safe : constant Boolean := not Might_Raise (N); 4025 -- True if N cannot raise an exception 4026 4027 Loc : constant Source_Ptr := Sloc (N); 4028 Op_Spec : constant Node_Id := Specification (N); 4029 P_Op_Spec : constant Node_Id := 4030 Build_Protected_Sub_Specification (N, Pid, Protected_Mode); 4031 4032 Lock_Kind : RE_Id; 4033 Lock_Name : Node_Id; 4034 Lock_Stmt : Node_Id; 4035 Object_Parm : Node_Id; 4036 Pformal : Node_Id; 4037 R : Node_Id; 4038 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning 4039 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning 4040 Stmts : List_Id; 4041 Sub_Body : Node_Id; 4042 Uactuals : List_Id; 4043 Unprot_Call : Node_Id; 4044 4045 begin 4046 -- Build a list of the formal parameters of the protected version of 4047 -- the subprogram to use as the actual parameters of the unprotected 4048 -- version. 4049 4050 Uactuals := New_List; 4051 Pformal := First (Parameter_Specifications (P_Op_Spec)); 4052 while Present (Pformal) loop 4053 Append_To (Uactuals, 4054 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal)))); 4055 Next (Pformal); 4056 end loop; 4057 4058 -- Make a call to the unprotected version of the subprogram built above 4059 -- for use by the protected version built below. 4060 4061 if Nkind (Op_Spec) = N_Function_Specification then 4062 if Exc_Safe then 4063 R := Make_Temporary (Loc, 'R'); 4064 4065 Unprot_Call := 4066 Make_Object_Declaration (Loc, 4067 Defining_Identifier => R, 4068 Constant_Present => True, 4069 Object_Definition => 4070 New_Copy (Result_Definition (N_Op_Spec)), 4071 Expression => 4072 Make_Function_Call (Loc, 4073 Name => 4074 Make_Identifier (Loc, 4075 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 4076 Parameter_Associations => Uactuals)); 4077 4078 Return_Stmt := 4079 Make_Simple_Return_Statement (Loc, 4080 Expression => New_Occurrence_Of (R, Loc)); 4081 4082 else 4083 Unprot_Call := 4084 Make_Simple_Return_Statement (Loc, 4085 Expression => 4086 Make_Function_Call (Loc, 4087 Name => 4088 Make_Identifier (Loc, 4089 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 4090 Parameter_Associations => Uactuals)); 4091 end if; 4092 4093 if Has_Aspect (Pid, Aspect_Exclusive_Functions) 4094 and then 4095 (No (Find_Value_Of_Aspect (Pid, Aspect_Exclusive_Functions)) 4096 or else 4097 Is_True (Static_Boolean (Find_Value_Of_Aspect 4098 (Pid, Aspect_Exclusive_Functions)))) 4099 then 4100 Lock_Kind := RE_Lock; 4101 else 4102 Lock_Kind := RE_Lock_Read_Only; 4103 end if; 4104 else 4105 Unprot_Call := 4106 Make_Procedure_Call_Statement (Loc, 4107 Name => 4108 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), 4109 Parameter_Associations => Uactuals); 4110 4111 Lock_Kind := RE_Lock; 4112 end if; 4113 4114 -- Wrap call in block that will be covered by an at_end handler 4115 4116 if not Exc_Safe then 4117 Unprot_Call := 4118 Make_Block_Statement (Loc, 4119 Handled_Statement_Sequence => 4120 Make_Handled_Sequence_Of_Statements (Loc, 4121 Statements => New_List (Unprot_Call))); 4122 end if; 4123 4124 -- Make the protected subprogram body. This locks the protected 4125 -- object and calls the unprotected version of the subprogram. 4126 4127 case Corresponding_Runtime_Package (Pid) is 4128 when System_Tasking_Protected_Objects_Entries => 4129 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc); 4130 4131 when System_Tasking_Protected_Objects_Single_Entry => 4132 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc); 4133 4134 when System_Tasking_Protected_Objects => 4135 Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc); 4136 4137 when others => 4138 raise Program_Error; 4139 end case; 4140 4141 Object_Parm := 4142 Make_Attribute_Reference (Loc, 4143 Prefix => 4144 Make_Selected_Component (Loc, 4145 Prefix => Make_Identifier (Loc, Name_uObject), 4146 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4147 Attribute_Name => Name_Unchecked_Access); 4148 4149 Lock_Stmt := 4150 Make_Procedure_Call_Statement (Loc, 4151 Name => Lock_Name, 4152 Parameter_Associations => New_List (Object_Parm)); 4153 4154 if Abort_Allowed then 4155 Stmts := New_List ( 4156 Build_Runtime_Call (Loc, RE_Abort_Defer), 4157 Lock_Stmt); 4158 4159 else 4160 Stmts := New_List (Lock_Stmt); 4161 end if; 4162 4163 if not Exc_Safe then 4164 Append (Unprot_Call, Stmts); 4165 else 4166 if Nkind (Op_Spec) = N_Function_Specification then 4167 Pre_Stmts := Stmts; 4168 Stmts := Empty_List; 4169 else 4170 Append (Unprot_Call, Stmts); 4171 end if; 4172 4173 -- Historical note: Previously, call to the cleanup was inserted 4174 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup, 4175 -- which is also shared by the 'not Exc_Safe' path. 4176 4177 Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts); 4178 4179 if Nkind (Op_Spec) = N_Function_Specification then 4180 Append_To (Stmts, Return_Stmt); 4181 Append_To (Pre_Stmts, 4182 Make_Block_Statement (Loc, 4183 Declarations => New_List (Unprot_Call), 4184 Handled_Statement_Sequence => 4185 Make_Handled_Sequence_Of_Statements (Loc, 4186 Statements => Stmts))); 4187 Stmts := Pre_Stmts; 4188 end if; 4189 end if; 4190 4191 Sub_Body := 4192 Make_Subprogram_Body (Loc, 4193 Declarations => Empty_List, 4194 Specification => P_Op_Spec, 4195 Handled_Statement_Sequence => 4196 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); 4197 4198 -- Mark this subprogram as a protected subprogram body so that the 4199 -- cleanup will be inserted. This is done only in the 'not Exc_Safe' 4200 -- path as otherwise the cleanup has already been inserted. 4201 4202 if not Exc_Safe then 4203 Set_Is_Protected_Subprogram_Body (Sub_Body); 4204 end if; 4205 4206 return Sub_Body; 4207 end Build_Protected_Subprogram_Body; 4208 4209 ------------------------------------- 4210 -- Build_Protected_Subprogram_Call -- 4211 ------------------------------------- 4212 4213 procedure Build_Protected_Subprogram_Call 4214 (N : Node_Id; 4215 Name : Node_Id; 4216 Rec : Node_Id; 4217 External : Boolean := True) 4218 is 4219 Loc : constant Source_Ptr := Sloc (N); 4220 Sub : constant Entity_Id := Entity (Name); 4221 New_Sub : Node_Id; 4222 Params : List_Id; 4223 4224 begin 4225 if External then 4226 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc); 4227 else 4228 New_Sub := 4229 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc); 4230 end if; 4231 4232 if Present (Parameter_Associations (N)) then 4233 Params := New_Copy_List_Tree (Parameter_Associations (N)); 4234 else 4235 Params := New_List; 4236 end if; 4237 4238 -- If the type is an untagged derived type, convert to the root type, 4239 -- which is the one on which the operations are defined. 4240 4241 if Nkind (Rec) = N_Unchecked_Type_Conversion 4242 and then not Is_Tagged_Type (Etype (Rec)) 4243 and then Is_Derived_Type (Etype (Rec)) 4244 then 4245 Set_Etype (Rec, Root_Type (Etype (Rec))); 4246 Set_Subtype_Mark (Rec, 4247 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N))); 4248 end if; 4249 4250 Prepend (Rec, Params); 4251 4252 if Ekind (Sub) = E_Procedure then 4253 Rewrite (N, 4254 Make_Procedure_Call_Statement (Loc, 4255 Name => New_Sub, 4256 Parameter_Associations => Params)); 4257 4258 else 4259 pragma Assert (Ekind (Sub) = E_Function); 4260 Rewrite (N, 4261 Make_Function_Call (Loc, 4262 Name => New_Sub, 4263 Parameter_Associations => Params)); 4264 4265 -- Preserve type of call for subsequent processing (required for 4266 -- call to Wrap_Transient_Expression in the case of a shared passive 4267 -- protected). 4268 4269 Set_Etype (N, Etype (New_Sub)); 4270 end if; 4271 4272 if External 4273 and then Nkind (Rec) = N_Unchecked_Type_Conversion 4274 and then Is_Entity_Name (Expression (Rec)) 4275 and then Is_Shared_Passive (Entity (Expression (Rec))) 4276 then 4277 Add_Shared_Var_Lock_Procs (N); 4278 end if; 4279 end Build_Protected_Subprogram_Call; 4280 4281 --------------------------------------------- 4282 -- Build_Protected_Subprogram_Call_Cleanup -- 4283 --------------------------------------------- 4284 4285 procedure Build_Protected_Subprogram_Call_Cleanup 4286 (Op_Spec : Node_Id; 4287 Conc_Typ : Node_Id; 4288 Loc : Source_Ptr; 4289 Stmts : List_Id) 4290 is 4291 Nam : Node_Id; 4292 4293 begin 4294 -- If the associated protected object has entries, a protected 4295 -- procedure has to service entry queues. In this case generate: 4296 4297 -- Service_Entries (_object._object'Access); 4298 4299 if Nkind (Op_Spec) = N_Procedure_Specification 4300 and then Has_Entries (Conc_Typ) 4301 then 4302 case Corresponding_Runtime_Package (Conc_Typ) is 4303 when System_Tasking_Protected_Objects_Entries => 4304 Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc); 4305 4306 when System_Tasking_Protected_Objects_Single_Entry => 4307 Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc); 4308 4309 when others => 4310 raise Program_Error; 4311 end case; 4312 4313 Append_To (Stmts, 4314 Make_Procedure_Call_Statement (Loc, 4315 Name => Nam, 4316 Parameter_Associations => New_List ( 4317 Make_Attribute_Reference (Loc, 4318 Prefix => 4319 Make_Selected_Component (Loc, 4320 Prefix => Make_Identifier (Loc, Name_uObject), 4321 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4322 Attribute_Name => Name_Unchecked_Access)))); 4323 4324 else 4325 -- Generate: 4326 -- Unlock (_object._object'Access); 4327 4328 case Corresponding_Runtime_Package (Conc_Typ) is 4329 when System_Tasking_Protected_Objects_Entries => 4330 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc); 4331 4332 when System_Tasking_Protected_Objects_Single_Entry => 4333 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc); 4334 4335 when System_Tasking_Protected_Objects => 4336 Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc); 4337 4338 when others => 4339 raise Program_Error; 4340 end case; 4341 4342 Append_To (Stmts, 4343 Make_Procedure_Call_Statement (Loc, 4344 Name => Nam, 4345 Parameter_Associations => New_List ( 4346 Make_Attribute_Reference (Loc, 4347 Prefix => 4348 Make_Selected_Component (Loc, 4349 Prefix => Make_Identifier (Loc, Name_uObject), 4350 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4351 Attribute_Name => Name_Unchecked_Access)))); 4352 end if; 4353 4354 -- Generate: 4355 -- Abort_Undefer; 4356 4357 if Abort_Allowed then 4358 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 4359 end if; 4360 end Build_Protected_Subprogram_Call_Cleanup; 4361 4362 ------------------------- 4363 -- Build_Selected_Name -- 4364 ------------------------- 4365 4366 function Build_Selected_Name 4367 (Prefix : Entity_Id; 4368 Selector : Entity_Id; 4369 Append_Char : Character := ' ') return Name_Id 4370 is 4371 Select_Buffer : String (1 .. Hostparm.Max_Name_Length); 4372 Select_Len : Natural; 4373 4374 begin 4375 Get_Name_String (Chars (Selector)); 4376 Select_Len := Name_Len; 4377 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len); 4378 Get_Name_String (Chars (Prefix)); 4379 4380 -- If scope is anonymous type, discard suffix to recover name of 4381 -- single protected object. Otherwise use protected type name. 4382 4383 if Name_Buffer (Name_Len) = 'T' then 4384 Name_Len := Name_Len - 1; 4385 end if; 4386 4387 Add_Str_To_Name_Buffer ("__"); 4388 for J in 1 .. Select_Len loop 4389 Add_Char_To_Name_Buffer (Select_Buffer (J)); 4390 end loop; 4391 4392 -- Now add the Append_Char if specified. The encoding to follow 4393 -- depends on the type of entity. If Append_Char is either 'N' or 'P', 4394 -- then the entity is associated to a protected type subprogram. 4395 -- Otherwise, it is a protected type entry. For each case, the 4396 -- encoding to follow for the suffix is documented in exp_dbug.ads. 4397 4398 -- It would be better to encapsulate this as a routine in Exp_Dbug ??? 4399 4400 if Append_Char /= ' ' then 4401 if Append_Char = 'P' or Append_Char = 'N' then 4402 Add_Char_To_Name_Buffer (Append_Char); 4403 return Name_Find; 4404 else 4405 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char)); 4406 return New_External_Name (Name_Find, ' ', -1); 4407 end if; 4408 else 4409 return Name_Find; 4410 end if; 4411 end Build_Selected_Name; 4412 4413 ----------------------------- 4414 -- Build_Simple_Entry_Call -- 4415 ----------------------------- 4416 4417 -- A task entry call is converted to a call to Call_Simple 4418 4419 -- declare 4420 -- P : parms := (parm, parm, parm); 4421 -- begin 4422 -- Call_Simple (acceptor-task, entry-index, P'Address); 4423 -- parm := P.param; 4424 -- parm := P.param; 4425 -- ... 4426 -- end; 4427 4428 -- Here Pnn is an aggregate of the type constructed for the entry to hold 4429 -- the parameters, and the constructed aggregate value contains either the 4430 -- parameters or, in the case of non-elementary types, references to these 4431 -- parameters. Then the address of this aggregate is passed to the runtime 4432 -- routine, along with the task id value and the task entry index value. 4433 -- Pnn is only required if parameters are present. 4434 4435 -- The assignments after the call are present only in the case of in-out 4436 -- or out parameters for elementary types, and are used to assign back the 4437 -- resulting values of such parameters. 4438 4439 -- Note: the reason that we insert a block here is that in the context 4440 -- of selects, conditional entry calls etc. the entry call statement 4441 -- appears on its own, not as an element of a list. 4442 4443 -- A protected entry call is converted to a Protected_Entry_Call: 4444 4445 -- declare 4446 -- P : E1_Params := (param, param, param); 4447 -- Pnn : Boolean; 4448 -- Bnn : Communications_Block; 4449 4450 -- declare 4451 -- P : E1_Params := (param, param, param); 4452 -- Bnn : Communications_Block; 4453 4454 -- begin 4455 -- Protected_Entry_Call ( 4456 -- Object => po._object'Access, 4457 -- E => <entry index>; 4458 -- Uninterpreted_Data => P'Address; 4459 -- Mode => Simple_Call; 4460 -- Block => Bnn); 4461 -- parm := P.param; 4462 -- parm := P.param; 4463 -- ... 4464 -- end; 4465 4466 procedure Build_Simple_Entry_Call 4467 (N : Node_Id; 4468 Concval : Node_Id; 4469 Ename : Node_Id; 4470 Index : Node_Id) 4471 is 4472 begin 4473 Expand_Call (N); 4474 4475 -- If call has been inlined, nothing left to do 4476 4477 if Nkind (N) = N_Block_Statement then 4478 return; 4479 end if; 4480 4481 -- Convert entry call to Call_Simple call 4482 4483 declare 4484 Loc : constant Source_Ptr := Sloc (N); 4485 Parms : constant List_Id := Parameter_Associations (N); 4486 Stats : constant List_Id := New_List; 4487 Actual : Node_Id; 4488 Call : Node_Id; 4489 Comm_Name : Entity_Id; 4490 Conctyp : Node_Id; 4491 Decls : List_Id; 4492 Ent : Entity_Id; 4493 Ent_Acc : Entity_Id; 4494 Formal : Node_Id; 4495 Iface_Tag : Entity_Id; 4496 Iface_Typ : Entity_Id; 4497 N_Node : Node_Id; 4498 N_Var : Node_Id; 4499 P : Entity_Id; 4500 Parm1 : Node_Id; 4501 Parm2 : Node_Id; 4502 Parm3 : Node_Id; 4503 Pdecl : Node_Id; 4504 Plist : List_Id; 4505 X : Entity_Id; 4506 Xdecl : Node_Id; 4507 4508 begin 4509 -- Simple entry and entry family cases merge here 4510 4511 Ent := Entity (Ename); 4512 Ent_Acc := Entry_Parameters_Type (Ent); 4513 Conctyp := Etype (Concval); 4514 4515 -- Special case for protected subprogram calls 4516 4517 if Is_Protected_Type (Conctyp) 4518 and then Is_Subprogram (Entity (Ename)) 4519 then 4520 if not Is_Eliminated (Entity (Ename)) then 4521 Build_Protected_Subprogram_Call 4522 (N, Ename, Convert_Concurrent (Concval, Conctyp)); 4523 Analyze (N); 4524 end if; 4525 4526 return; 4527 end if; 4528 4529 -- First parameter is the Task_Id value from the task value or the 4530 -- Object from the protected object value, obtained by selecting 4531 -- the _Task_Id or _Object from the result of doing an unchecked 4532 -- conversion to convert the value to the corresponding record type. 4533 4534 if Nkind (Concval) = N_Function_Call 4535 and then Is_Task_Type (Conctyp) 4536 and then Ada_Version >= Ada_2005 4537 then 4538 declare 4539 ExpR : constant Node_Id := Relocate_Node (Concval); 4540 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR); 4541 Decl : Node_Id; 4542 4543 begin 4544 Decl := 4545 Make_Object_Declaration (Loc, 4546 Defining_Identifier => Obj, 4547 Object_Definition => New_Occurrence_Of (Conctyp, Loc), 4548 Expression => ExpR); 4549 Set_Etype (Obj, Conctyp); 4550 Decls := New_List (Decl); 4551 Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); 4552 end; 4553 4554 else 4555 Decls := New_List; 4556 end if; 4557 4558 Parm1 := Concurrent_Ref (Concval); 4559 4560 -- Second parameter is the entry index, computed by the routine 4561 -- provided for this purpose. The value of this expression is 4562 -- assigned to an intermediate variable to assure that any entry 4563 -- family index expressions are evaluated before the entry 4564 -- parameters. 4565 4566 if not Is_Protected_Type (Conctyp) 4567 or else 4568 Corresponding_Runtime_Package (Conctyp) = 4569 System_Tasking_Protected_Objects_Entries 4570 then 4571 X := Make_Defining_Identifier (Loc, Name_uX); 4572 4573 Xdecl := 4574 Make_Object_Declaration (Loc, 4575 Defining_Identifier => X, 4576 Object_Definition => 4577 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), 4578 Expression => Actual_Index_Expression ( 4579 Loc, Entity (Ename), Index, Concval)); 4580 4581 Append_To (Decls, Xdecl); 4582 Parm2 := New_Occurrence_Of (X, Loc); 4583 4584 else 4585 Xdecl := Empty; 4586 Parm2 := Empty; 4587 end if; 4588 4589 -- The third parameter is the packaged parameters. If there are 4590 -- none, then it is just the null address, since nothing is passed. 4591 4592 if No (Parms) then 4593 Parm3 := New_Occurrence_Of (RTE (RE_Null_Address), Loc); 4594 P := Empty; 4595 4596 -- Case of parameters present, where third argument is the address 4597 -- of a packaged record containing the required parameter values. 4598 4599 else 4600 -- First build a list of parameter values, which are references to 4601 -- objects of the parameter types. 4602 4603 Plist := New_List; 4604 4605 Actual := First_Actual (N); 4606 Formal := First_Formal (Ent); 4607 while Present (Actual) loop 4608 4609 -- If it is a by-copy type, copy it to a new variable. The 4610 -- packaged record has a field that points to this variable. 4611 4612 if Is_By_Copy_Type (Etype (Actual)) then 4613 N_Node := 4614 Make_Object_Declaration (Loc, 4615 Defining_Identifier => Make_Temporary (Loc, 'J'), 4616 Aliased_Present => True, 4617 Object_Definition => 4618 New_Occurrence_Of (Etype (Formal), Loc)); 4619 4620 -- Mark the object as not needing initialization since the 4621 -- initialization is performed separately, avoiding errors 4622 -- on cases such as formals of null-excluding access types. 4623 4624 Set_No_Initialization (N_Node); 4625 4626 -- We must make a separate assignment statement for the 4627 -- case of limited types. We cannot assign it unless the 4628 -- Assignment_OK flag is set first. An out formal of an 4629 -- access type or whose type has a Default_Value must also 4630 -- be initialized from the actual (see RM 6.4.1 (13-13.1)), 4631 -- but no constraint, predicate, or null-exclusion check is 4632 -- applied before the call. 4633 4634 if Ekind (Formal) /= E_Out_Parameter 4635 or else Is_Access_Type (Etype (Formal)) 4636 or else 4637 (Is_Scalar_Type (Etype (Formal)) 4638 and then 4639 Present (Default_Aspect_Value (Etype (Formal)))) 4640 then 4641 N_Var := 4642 New_Occurrence_Of (Defining_Identifier (N_Node), Loc); 4643 Set_Assignment_OK (N_Var); 4644 Append_To (Stats, 4645 Make_Assignment_Statement (Loc, 4646 Name => N_Var, 4647 Expression => Relocate_Node (Actual))); 4648 4649 -- Mark the object as internal, so we don't later reset 4650 -- No_Initialization flag in Default_Initialize_Object, 4651 -- which would lead to needless default initialization. 4652 -- We don't set this outside the if statement, because 4653 -- out scalar parameters without Default_Value do require 4654 -- default initialization if Initialize_Scalars applies. 4655 4656 Set_Is_Internal (Defining_Identifier (N_Node)); 4657 4658 -- If actual is an out parameter of a null-excluding 4659 -- access type, there is access check on entry, so set 4660 -- Suppress_Assignment_Checks on the generated statement 4661 -- that assigns the actual to the parameter block. 4662 4663 Set_Suppress_Assignment_Checks (Last (Stats)); 4664 end if; 4665 4666 Append (N_Node, Decls); 4667 4668 Append_To (Plist, 4669 Make_Attribute_Reference (Loc, 4670 Attribute_Name => Name_Unchecked_Access, 4671 Prefix => 4672 New_Occurrence_Of 4673 (Defining_Identifier (N_Node), Loc))); 4674 4675 else 4676 -- Interface class-wide formal 4677 4678 if Ada_Version >= Ada_2005 4679 and then Ekind (Etype (Formal)) = E_Class_Wide_Type 4680 and then Is_Interface (Etype (Formal)) 4681 then 4682 Iface_Typ := Etype (Etype (Formal)); 4683 4684 -- Generate: 4685 -- formal_iface_type! (actual.iface_tag)'reference 4686 4687 Iface_Tag := 4688 Find_Interface_Tag (Etype (Actual), Iface_Typ); 4689 pragma Assert (Present (Iface_Tag)); 4690 4691 Append_To (Plist, 4692 Make_Reference (Loc, 4693 Unchecked_Convert_To (Iface_Typ, 4694 Make_Selected_Component (Loc, 4695 Prefix => 4696 Relocate_Node (Actual), 4697 Selector_Name => 4698 New_Occurrence_Of (Iface_Tag, Loc))))); 4699 else 4700 -- Generate: 4701 -- actual'reference 4702 4703 Append_To (Plist, 4704 Make_Reference (Loc, Relocate_Node (Actual))); 4705 end if; 4706 end if; 4707 4708 Next_Actual (Actual); 4709 Next_Formal_With_Extras (Formal); 4710 end loop; 4711 4712 -- Now build the declaration of parameters initialized with the 4713 -- aggregate containing this constructed parameter list. 4714 4715 P := Make_Defining_Identifier (Loc, Name_uP); 4716 4717 Pdecl := 4718 Make_Object_Declaration (Loc, 4719 Defining_Identifier => P, 4720 Object_Definition => 4721 New_Occurrence_Of (Designated_Type (Ent_Acc), Loc), 4722 Expression => 4723 Make_Aggregate (Loc, Expressions => Plist)); 4724 4725 Parm3 := 4726 Make_Attribute_Reference (Loc, 4727 Prefix => New_Occurrence_Of (P, Loc), 4728 Attribute_Name => Name_Address); 4729 4730 Append (Pdecl, Decls); 4731 end if; 4732 4733 -- Now we can create the call, case of protected type 4734 4735 if Is_Protected_Type (Conctyp) then 4736 case Corresponding_Runtime_Package (Conctyp) is 4737 when System_Tasking_Protected_Objects_Entries => 4738 4739 -- Change the type of the index declaration 4740 4741 Set_Object_Definition (Xdecl, 4742 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)); 4743 4744 -- Some additional declarations for protected entry calls 4745 4746 if No (Decls) then 4747 Decls := New_List; 4748 end if; 4749 4750 -- Bnn : Communications_Block; 4751 4752 Comm_Name := Make_Temporary (Loc, 'B'); 4753 4754 Append_To (Decls, 4755 Make_Object_Declaration (Loc, 4756 Defining_Identifier => Comm_Name, 4757 Object_Definition => 4758 New_Occurrence_Of 4759 (RTE (RE_Communication_Block), Loc))); 4760 4761 -- Some additional statements for protected entry calls 4762 4763 -- Protected_Entry_Call 4764 -- (Object => po._object'Access, 4765 -- E => <entry index>; 4766 -- Uninterpreted_Data => P'Address; 4767 -- Mode => Simple_Call; 4768 -- Block => Bnn); 4769 4770 Call := 4771 Make_Procedure_Call_Statement (Loc, 4772 Name => 4773 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), 4774 4775 Parameter_Associations => New_List ( 4776 Make_Attribute_Reference (Loc, 4777 Attribute_Name => Name_Unchecked_Access, 4778 Prefix => Parm1), 4779 Parm2, 4780 Parm3, 4781 New_Occurrence_Of (RTE (RE_Simple_Call), Loc), 4782 New_Occurrence_Of (Comm_Name, Loc))); 4783 4784 when System_Tasking_Protected_Objects_Single_Entry => 4785 4786 -- Protected_Single_Entry_Call 4787 -- (Object => po._object'Access, 4788 -- Uninterpreted_Data => P'Address); 4789 4790 Call := 4791 Make_Procedure_Call_Statement (Loc, 4792 Name => 4793 New_Occurrence_Of 4794 (RTE (RE_Protected_Single_Entry_Call), Loc), 4795 4796 Parameter_Associations => New_List ( 4797 Make_Attribute_Reference (Loc, 4798 Attribute_Name => Name_Unchecked_Access, 4799 Prefix => Parm1), 4800 Parm3)); 4801 4802 when others => 4803 raise Program_Error; 4804 end case; 4805 4806 -- Case of task type 4807 4808 else 4809 Call := 4810 Make_Procedure_Call_Statement (Loc, 4811 Name => 4812 New_Occurrence_Of (RTE (RE_Call_Simple), Loc), 4813 Parameter_Associations => New_List (Parm1, Parm2, Parm3)); 4814 4815 end if; 4816 4817 Append_To (Stats, Call); 4818 4819 -- If there are out or in/out parameters by copy add assignment 4820 -- statements for the result values. 4821 4822 if Present (Parms) then 4823 Actual := First_Actual (N); 4824 Formal := First_Formal (Ent); 4825 4826 Set_Assignment_OK (Actual); 4827 while Present (Actual) loop 4828 if Is_By_Copy_Type (Etype (Actual)) 4829 and then Ekind (Formal) /= E_In_Parameter 4830 then 4831 N_Node := 4832 Make_Assignment_Statement (Loc, 4833 Name => New_Copy (Actual), 4834 Expression => 4835 Make_Explicit_Dereference (Loc, 4836 Make_Selected_Component (Loc, 4837 Prefix => New_Occurrence_Of (P, Loc), 4838 Selector_Name => 4839 Make_Identifier (Loc, Chars (Formal))))); 4840 4841 -- In all cases (including limited private types) we want 4842 -- the assignment to be valid. 4843 4844 Set_Assignment_OK (Name (N_Node)); 4845 4846 -- If the call is the triggering alternative in an 4847 -- asynchronous select, or the entry_call alternative of a 4848 -- conditional entry call, the assignments for in-out 4849 -- parameters are incorporated into the statement list that 4850 -- follows, so that there are executed only if the entry 4851 -- call succeeds. 4852 4853 if (Nkind (Parent (N)) = N_Triggering_Alternative 4854 and then N = Triggering_Statement (Parent (N))) 4855 or else 4856 (Nkind (Parent (N)) = N_Entry_Call_Alternative 4857 and then N = Entry_Call_Statement (Parent (N))) 4858 then 4859 if No (Statements (Parent (N))) then 4860 Set_Statements (Parent (N), New_List); 4861 end if; 4862 4863 Prepend (N_Node, Statements (Parent (N))); 4864 4865 else 4866 Insert_After (Call, N_Node); 4867 end if; 4868 end if; 4869 4870 Next_Actual (Actual); 4871 Next_Formal_With_Extras (Formal); 4872 end loop; 4873 end if; 4874 4875 -- Finally, create block and analyze it 4876 4877 Rewrite (N, 4878 Make_Block_Statement (Loc, 4879 Declarations => Decls, 4880 Handled_Statement_Sequence => 4881 Make_Handled_Sequence_Of_Statements (Loc, 4882 Statements => Stats))); 4883 4884 Analyze (N); 4885 end; 4886 end Build_Simple_Entry_Call; 4887 4888 -------------------------------- 4889 -- Build_Task_Activation_Call -- 4890 -------------------------------- 4891 4892 procedure Build_Task_Activation_Call (N : Node_Id) is 4893 function Activation_Call_Loc return Source_Ptr; 4894 -- Find a suitable source location for the activation call 4895 4896 ------------------------- 4897 -- Activation_Call_Loc -- 4898 ------------------------- 4899 4900 function Activation_Call_Loc return Source_Ptr is 4901 begin 4902 -- The activation call must carry the location of the "end" keyword 4903 -- when the context is a package declaration. 4904 4905 if Nkind (N) = N_Package_Declaration then 4906 return End_Keyword_Location (N); 4907 4908 -- Otherwise the activation call must carry the location of the 4909 -- "begin" keyword. 4910 4911 else 4912 return Begin_Keyword_Location (N); 4913 end if; 4914 end Activation_Call_Loc; 4915 4916 -- Local variables 4917 4918 Chain : Entity_Id; 4919 Call : Node_Id; 4920 Loc : Source_Ptr; 4921 Name : Node_Id; 4922 Owner : Node_Id; 4923 Stmt : Node_Id; 4924 4925 -- Start of processing for Build_Task_Activation_Call 4926 4927 begin 4928 -- For sequential elaboration policy, all the tasks will be activated at 4929 -- the end of the elaboration. 4930 4931 if Partition_Elaboration_Policy = 'S' then 4932 return; 4933 4934 -- Do not create an activation call for a package spec if the package 4935 -- has a completing body. The activation call will be inserted after 4936 -- the "begin" of the body. 4937 4938 elsif Nkind (N) = N_Package_Declaration 4939 and then Present (Corresponding_Body (N)) 4940 then 4941 return; 4942 end if; 4943 4944 -- Obtain the activation chain entity. Block statements, entry bodies, 4945 -- subprogram bodies, and task bodies keep the entity in their nodes. 4946 -- Package bodies on the other hand store it in the declaration of the 4947 -- corresponding package spec. 4948 4949 Owner := N; 4950 4951 if Nkind (Owner) = N_Package_Body then 4952 Owner := Unit_Declaration_Node (Corresponding_Spec (Owner)); 4953 end if; 4954 4955 Chain := Activation_Chain_Entity (Owner); 4956 4957 -- Nothing to do when there are no tasks to activate. This is indicated 4958 -- by a missing activation chain entity; also skip generating it when 4959 -- it is a ghost entity. 4960 4961 if No (Chain) or else Is_Ignored_Ghost_Entity (Chain) then 4962 return; 4963 4964 -- The availability of the activation chain entity does not ensure 4965 -- that we have tasks to activate because it may have been declared 4966 -- by the frontend to pass a required extra formal to a build-in-place 4967 -- subprogram call. If we are within the scope of a protected type and 4968 -- pragma Detect_Blocking is active we can assume that no tasks will be 4969 -- activated; if tasks are created in a protected object and this pragma 4970 -- is active then the frontend emits a warning and Program_Error is 4971 -- raised at runtime. 4972 4973 elsif Detect_Blocking and then Within_Protected_Type (Current_Scope) then 4974 return; 4975 end if; 4976 4977 -- The location of the activation call must be as close as possible to 4978 -- the intended semantic location of the activation because the ABE 4979 -- mechanism relies heavily on accurate locations. 4980 4981 Loc := Activation_Call_Loc; 4982 4983 if Restricted_Profile then 4984 Name := New_Occurrence_Of (RTE (RE_Activate_Restricted_Tasks), Loc); 4985 else 4986 Name := New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc); 4987 end if; 4988 4989 Call := 4990 Make_Procedure_Call_Statement (Loc, 4991 Name => Name, 4992 Parameter_Associations => 4993 New_List (Make_Attribute_Reference (Loc, 4994 Prefix => New_Occurrence_Of (Chain, Loc), 4995 Attribute_Name => Name_Unchecked_Access))); 4996 4997 if Nkind (N) = N_Package_Declaration then 4998 if Present (Private_Declarations (Specification (N))) then 4999 Append (Call, Private_Declarations (Specification (N))); 5000 else 5001 Append (Call, Visible_Declarations (Specification (N))); 5002 end if; 5003 5004 else 5005 -- The call goes at the start of the statement sequence after the 5006 -- start of exception range label if one is present. 5007 5008 if Present (Handled_Statement_Sequence (N)) then 5009 Stmt := First (Statements (Handled_Statement_Sequence (N))); 5010 5011 -- A special case, skip exception range label if one is present 5012 -- (from front end zcx processing). 5013 5014 if Nkind (Stmt) = N_Label and then Exception_Junk (Stmt) then 5015 Next (Stmt); 5016 end if; 5017 5018 -- Another special case, if the first statement is a block from 5019 -- optimization of a local raise to a goto, then the call goes 5020 -- inside this block. 5021 5022 if Nkind (Stmt) = N_Block_Statement 5023 and then Exception_Junk (Stmt) 5024 then 5025 Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); 5026 end if; 5027 5028 -- Insertion point is after any exception label pushes, since we 5029 -- want it covered by any local handlers. 5030 5031 while Nkind (Stmt) in N_Push_xxx_Label loop 5032 Next (Stmt); 5033 end loop; 5034 5035 -- Now we have the proper insertion point 5036 5037 Insert_Before (Stmt, Call); 5038 5039 else 5040 Set_Handled_Statement_Sequence (N, 5041 Make_Handled_Sequence_Of_Statements (Loc, 5042 Statements => New_List (Call))); 5043 end if; 5044 end if; 5045 5046 Analyze (Call); 5047 5048 if Legacy_Elaboration_Checks then 5049 Check_Task_Activation (N); 5050 end if; 5051 end Build_Task_Activation_Call; 5052 5053 ------------------------------- 5054 -- Build_Task_Allocate_Block -- 5055 ------------------------------- 5056 5057 procedure Build_Task_Allocate_Block 5058 (Actions : List_Id; 5059 N : Node_Id; 5060 Args : List_Id) 5061 is 5062 T : constant Entity_Id := Entity (Expression (N)); 5063 Init : constant Entity_Id := Base_Init_Proc (T); 5064 Loc : constant Source_Ptr := Sloc (N); 5065 Chain : constant Entity_Id := 5066 Make_Defining_Identifier (Loc, Name_uChain); 5067 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 5068 Block : Node_Id; 5069 5070 begin 5071 Block := 5072 Make_Block_Statement (Loc, 5073 Identifier => New_Occurrence_Of (Blkent, Loc), 5074 Declarations => New_List ( 5075 5076 -- _Chain : Activation_Chain; 5077 5078 Make_Object_Declaration (Loc, 5079 Defining_Identifier => Chain, 5080 Aliased_Present => True, 5081 Object_Definition => 5082 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5083 5084 Handled_Statement_Sequence => 5085 Make_Handled_Sequence_Of_Statements (Loc, 5086 5087 Statements => New_List ( 5088 5089 -- Init (Args); 5090 5091 Make_Procedure_Call_Statement (Loc, 5092 Name => New_Occurrence_Of (Init, Loc), 5093 Parameter_Associations => Args), 5094 5095 -- Activate_Tasks (_Chain); 5096 5097 Make_Procedure_Call_Statement (Loc, 5098 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 5099 Parameter_Associations => New_List ( 5100 Make_Attribute_Reference (Loc, 5101 Prefix => New_Occurrence_Of (Chain, Loc), 5102 Attribute_Name => Name_Unchecked_Access))))), 5103 5104 Has_Created_Identifier => True, 5105 Is_Task_Allocation_Block => True); 5106 5107 Append_To (Actions, 5108 Make_Implicit_Label_Declaration (Loc, 5109 Defining_Identifier => Blkent, 5110 Label_Construct => Block)); 5111 5112 Append_To (Actions, Block); 5113 5114 Set_Activation_Chain_Entity (Block, Chain); 5115 end Build_Task_Allocate_Block; 5116 5117 ----------------------------------------------- 5118 -- Build_Task_Allocate_Block_With_Init_Stmts -- 5119 ----------------------------------------------- 5120 5121 procedure Build_Task_Allocate_Block_With_Init_Stmts 5122 (Actions : List_Id; 5123 N : Node_Id; 5124 Init_Stmts : List_Id) 5125 is 5126 Loc : constant Source_Ptr := Sloc (N); 5127 Chain : constant Entity_Id := 5128 Make_Defining_Identifier (Loc, Name_uChain); 5129 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 5130 Block : Node_Id; 5131 5132 begin 5133 Append_To (Init_Stmts, 5134 Make_Procedure_Call_Statement (Loc, 5135 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 5136 Parameter_Associations => New_List ( 5137 Make_Attribute_Reference (Loc, 5138 Prefix => New_Occurrence_Of (Chain, Loc), 5139 Attribute_Name => Name_Unchecked_Access)))); 5140 5141 Block := 5142 Make_Block_Statement (Loc, 5143 Identifier => New_Occurrence_Of (Blkent, Loc), 5144 Declarations => New_List ( 5145 5146 -- _Chain : Activation_Chain; 5147 5148 Make_Object_Declaration (Loc, 5149 Defining_Identifier => Chain, 5150 Aliased_Present => True, 5151 Object_Definition => 5152 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5153 5154 Handled_Statement_Sequence => 5155 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts), 5156 5157 Has_Created_Identifier => True, 5158 Is_Task_Allocation_Block => True); 5159 5160 Append_To (Actions, 5161 Make_Implicit_Label_Declaration (Loc, 5162 Defining_Identifier => Blkent, 5163 Label_Construct => Block)); 5164 5165 Append_To (Actions, Block); 5166 5167 Set_Activation_Chain_Entity (Block, Chain); 5168 end Build_Task_Allocate_Block_With_Init_Stmts; 5169 5170 ----------------------------------- 5171 -- Build_Task_Proc_Specification -- 5172 ----------------------------------- 5173 5174 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is 5175 Loc : constant Source_Ptr := Sloc (T); 5176 Spec_Id : Entity_Id; 5177 5178 begin 5179 -- Case of explicit task type, suffix TB 5180 5181 if Comes_From_Source (T) then 5182 Spec_Id := 5183 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB")); 5184 5185 -- Case of anonymous task type, suffix B 5186 5187 else 5188 Spec_Id := 5189 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B')); 5190 end if; 5191 5192 Set_Is_Internal (Spec_Id); 5193 5194 -- Associate the procedure with the task, if this is the declaration 5195 -- (and not the body) of the procedure. 5196 5197 if No (Task_Body_Procedure (T)) then 5198 Set_Task_Body_Procedure (T, Spec_Id); 5199 end if; 5200 5201 return 5202 Make_Procedure_Specification (Loc, 5203 Defining_Unit_Name => Spec_Id, 5204 Parameter_Specifications => New_List ( 5205 Make_Parameter_Specification (Loc, 5206 Defining_Identifier => 5207 Make_Defining_Identifier (Loc, Name_uTask), 5208 Parameter_Type => 5209 Make_Access_Definition (Loc, 5210 Subtype_Mark => 5211 New_Occurrence_Of (Corresponding_Record_Type (T), Loc))))); 5212 end Build_Task_Proc_Specification; 5213 5214 --------------------------------------- 5215 -- Build_Unprotected_Subprogram_Body -- 5216 --------------------------------------- 5217 5218 function Build_Unprotected_Subprogram_Body 5219 (N : Node_Id; 5220 Pid : Node_Id) return Node_Id 5221 is 5222 Decls : constant List_Id := Declarations (N); 5223 5224 begin 5225 -- Add renamings for the Protection object, discriminals, privals, and 5226 -- the entry index constant for use by debugger. 5227 5228 Debug_Private_Data_Declarations (Decls); 5229 5230 -- Make an unprotected version of the subprogram for use within the same 5231 -- object, with a new name and an additional parameter representing the 5232 -- object. 5233 5234 return 5235 Make_Subprogram_Body (Sloc (N), 5236 Specification => 5237 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), 5238 Declarations => Decls, 5239 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 5240 end Build_Unprotected_Subprogram_Body; 5241 5242 ---------------------------- 5243 -- Collect_Entry_Families -- 5244 ---------------------------- 5245 5246 procedure Collect_Entry_Families 5247 (Loc : Source_Ptr; 5248 Cdecls : List_Id; 5249 Current_Node : in out Node_Id; 5250 Conctyp : Entity_Id) 5251 is 5252 Efam : Entity_Id; 5253 Efam_Decl : Node_Id; 5254 Efam_Type : Entity_Id; 5255 5256 begin 5257 Efam := First_Entity (Conctyp); 5258 while Present (Efam) loop 5259 if Ekind (Efam) = E_Entry_Family then 5260 Efam_Type := Make_Temporary (Loc, 'F'); 5261 5262 declare 5263 Eityp : constant Entity_Id := Entry_Index_Type (Efam); 5264 Lo : constant Node_Id := Type_Low_Bound (Eityp); 5265 Hi : constant Node_Id := Type_High_Bound (Eityp); 5266 Bdecl : Node_Id; 5267 Bityp : Entity_Id; 5268 5269 begin 5270 Bityp := Base_Type (Eityp); 5271 5272 if Is_Potentially_Large_Family (Bityp, Conctyp, Lo, Hi) then 5273 Bityp := Make_Temporary (Loc, 'B'); 5274 5275 Bdecl := 5276 Make_Subtype_Declaration (Loc, 5277 Defining_Identifier => Bityp, 5278 Subtype_Indication => 5279 Make_Subtype_Indication (Loc, 5280 Subtype_Mark => 5281 New_Occurrence_Of (Standard_Integer, Loc), 5282 Constraint => 5283 Make_Range_Constraint (Loc, 5284 Range_Expression => Make_Range (Loc, 5285 Make_Integer_Literal 5286 (Loc, -Entry_Family_Bound), 5287 Make_Integer_Literal 5288 (Loc, Entry_Family_Bound - 1))))); 5289 5290 Insert_After (Current_Node, Bdecl); 5291 Current_Node := Bdecl; 5292 Analyze (Bdecl); 5293 end if; 5294 5295 Efam_Decl := 5296 Make_Full_Type_Declaration (Loc, 5297 Defining_Identifier => Efam_Type, 5298 Type_Definition => 5299 Make_Unconstrained_Array_Definition (Loc, 5300 Subtype_Marks => 5301 (New_List (New_Occurrence_Of (Bityp, Loc))), 5302 5303 Component_Definition => 5304 Make_Component_Definition (Loc, 5305 Aliased_Present => False, 5306 Subtype_Indication => 5307 New_Occurrence_Of (Standard_Character, Loc)))); 5308 end; 5309 5310 Insert_After (Current_Node, Efam_Decl); 5311 Current_Node := Efam_Decl; 5312 Analyze (Efam_Decl); 5313 5314 Append_To (Cdecls, 5315 Make_Component_Declaration (Loc, 5316 Defining_Identifier => 5317 Make_Defining_Identifier (Loc, Chars (Efam)), 5318 5319 Component_Definition => 5320 Make_Component_Definition (Loc, 5321 Aliased_Present => False, 5322 Subtype_Indication => 5323 Make_Subtype_Indication (Loc, 5324 Subtype_Mark => 5325 New_Occurrence_Of (Efam_Type, Loc), 5326 5327 Constraint => 5328 Make_Index_Or_Discriminant_Constraint (Loc, 5329 Constraints => New_List ( 5330 New_Occurrence_Of (Entry_Index_Type (Efam), 5331 Loc))))))); 5332 end if; 5333 5334 Next_Entity (Efam); 5335 end loop; 5336 end Collect_Entry_Families; 5337 5338 ----------------------- 5339 -- Concurrent_Object -- 5340 ----------------------- 5341 5342 function Concurrent_Object 5343 (Spec_Id : Entity_Id; 5344 Conc_Typ : Entity_Id) return Entity_Id 5345 is 5346 begin 5347 -- Parameter _O or _object 5348 5349 if Is_Protected_Type (Conc_Typ) then 5350 return First_Formal (Protected_Body_Subprogram (Spec_Id)); 5351 5352 -- Parameter _task 5353 5354 else 5355 pragma Assert (Is_Task_Type (Conc_Typ)); 5356 return First_Formal (Task_Body_Procedure (Conc_Typ)); 5357 end if; 5358 end Concurrent_Object; 5359 5360 ---------------------- 5361 -- Copy_Result_Type -- 5362 ---------------------- 5363 5364 function Copy_Result_Type (Res : Node_Id) return Node_Id is 5365 New_Res : constant Node_Id := New_Copy_Tree (Res); 5366 Par_Spec : Node_Id; 5367 Formal : Entity_Id; 5368 5369 begin 5370 -- If the result type is an access_to_subprogram, we must create new 5371 -- entities for its spec. 5372 5373 if Nkind (New_Res) = N_Access_Definition 5374 and then Present (Access_To_Subprogram_Definition (New_Res)) 5375 then 5376 -- Provide new entities for the formals 5377 5378 Par_Spec := First (Parameter_Specifications 5379 (Access_To_Subprogram_Definition (New_Res))); 5380 while Present (Par_Spec) loop 5381 Formal := Defining_Identifier (Par_Spec); 5382 Set_Defining_Identifier (Par_Spec, 5383 Make_Defining_Identifier (Sloc (Formal), Chars (Formal))); 5384 Next (Par_Spec); 5385 end loop; 5386 end if; 5387 5388 return New_Res; 5389 end Copy_Result_Type; 5390 5391 -------------------- 5392 -- Concurrent_Ref -- 5393 -------------------- 5394 5395 -- The expression returned for a reference to a concurrent object has the 5396 -- form: 5397 5398 -- taskV!(name)._Task_Id 5399 5400 -- for a task, and 5401 5402 -- objectV!(name)._Object 5403 5404 -- for a protected object. For the case of an access to a concurrent 5405 -- object, there is an extra explicit dereference: 5406 5407 -- taskV!(name.all)._Task_Id 5408 -- objectV!(name.all)._Object 5409 5410 -- here taskV and objectV are the types for the associated records, which 5411 -- contain the required _Task_Id and _Object fields for tasks and protected 5412 -- objects, respectively. 5413 5414 -- For the case of a task type name, the expression is 5415 5416 -- Self; 5417 5418 -- i.e. a call to the Self function which returns precisely this Task_Id 5419 5420 -- For the case of a protected type name, the expression is 5421 5422 -- objectR 5423 5424 -- which is a renaming of the _object field of the current object 5425 -- record, passed into protected operations as a parameter. 5426 5427 function Concurrent_Ref (N : Node_Id) return Node_Id is 5428 Loc : constant Source_Ptr := Sloc (N); 5429 Ntyp : constant Entity_Id := Etype (N); 5430 Dtyp : Entity_Id; 5431 Sel : Name_Id; 5432 5433 function Is_Current_Task (T : Entity_Id) return Boolean; 5434 -- Check whether the reference is to the immediately enclosing task 5435 -- type, or to an outer one (rare but legal). 5436 5437 --------------------- 5438 -- Is_Current_Task -- 5439 --------------------- 5440 5441 function Is_Current_Task (T : Entity_Id) return Boolean is 5442 Scop : Entity_Id; 5443 5444 begin 5445 Scop := Current_Scope; 5446 while Present (Scop) and then Scop /= Standard_Standard loop 5447 if Scop = T then 5448 return True; 5449 5450 elsif Is_Task_Type (Scop) then 5451 return False; 5452 5453 -- If this is a procedure nested within the task type, we must 5454 -- assume that it can be called from an inner task, and therefore 5455 -- cannot treat it as a local reference. 5456 5457 elsif Is_Overloadable (Scop) and then In_Open_Scopes (T) then 5458 return False; 5459 5460 else 5461 Scop := Scope (Scop); 5462 end if; 5463 end loop; 5464 5465 -- We know that we are within the task body, so should have found it 5466 -- in scope. 5467 5468 raise Program_Error; 5469 end Is_Current_Task; 5470 5471 -- Start of processing for Concurrent_Ref 5472 5473 begin 5474 if Is_Access_Type (Ntyp) then 5475 Dtyp := Designated_Type (Ntyp); 5476 5477 if Is_Protected_Type (Dtyp) then 5478 Sel := Name_uObject; 5479 else 5480 Sel := Name_uTask_Id; 5481 end if; 5482 5483 return 5484 Make_Selected_Component (Loc, 5485 Prefix => 5486 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp), 5487 Make_Explicit_Dereference (Loc, N)), 5488 Selector_Name => Make_Identifier (Loc, Sel)); 5489 5490 elsif Is_Entity_Name (N) and then Is_Concurrent_Type (Entity (N)) then 5491 if Is_Task_Type (Entity (N)) then 5492 5493 if Is_Current_Task (Entity (N)) then 5494 return 5495 Make_Function_Call (Loc, 5496 Name => New_Occurrence_Of (RTE (RE_Self), Loc)); 5497 5498 else 5499 declare 5500 Decl : Node_Id; 5501 T_Self : constant Entity_Id := Make_Temporary (Loc, 'T'); 5502 T_Body : constant Node_Id := 5503 Parent (Corresponding_Body (Parent (Entity (N)))); 5504 5505 begin 5506 Decl := 5507 Make_Object_Declaration (Loc, 5508 Defining_Identifier => T_Self, 5509 Object_Definition => 5510 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 5511 Expression => 5512 Make_Function_Call (Loc, 5513 Name => New_Occurrence_Of (RTE (RE_Self), Loc))); 5514 Prepend (Decl, Declarations (T_Body)); 5515 Analyze (Decl); 5516 Set_Scope (T_Self, Entity (N)); 5517 return New_Occurrence_Of (T_Self, Loc); 5518 end; 5519 end if; 5520 5521 else 5522 pragma Assert (Is_Protected_Type (Entity (N))); 5523 5524 return 5525 New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc); 5526 end if; 5527 5528 else 5529 if Is_Protected_Type (Ntyp) then 5530 Sel := Name_uObject; 5531 elsif Is_Task_Type (Ntyp) then 5532 Sel := Name_uTask_Id; 5533 else 5534 raise Program_Error; 5535 end if; 5536 5537 return 5538 Make_Selected_Component (Loc, 5539 Prefix => 5540 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp), 5541 New_Copy_Tree (N)), 5542 Selector_Name => Make_Identifier (Loc, Sel)); 5543 end if; 5544 end Concurrent_Ref; 5545 5546 ------------------------ 5547 -- Convert_Concurrent -- 5548 ------------------------ 5549 5550 function Convert_Concurrent 5551 (N : Node_Id; 5552 Typ : Entity_Id) return Node_Id 5553 is 5554 begin 5555 if not Is_Concurrent_Type (Typ) then 5556 return N; 5557 else 5558 return 5559 Unchecked_Convert_To 5560 (Corresponding_Record_Type (Typ), New_Copy_Tree (N)); 5561 end if; 5562 end Convert_Concurrent; 5563 5564 ------------------------------------- 5565 -- Create_Secondary_Stack_For_Task -- 5566 ------------------------------------- 5567 5568 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean is 5569 begin 5570 return 5571 (Restriction_Active (No_Implicit_Heap_Allocations) 5572 or else Restriction_Active (No_Implicit_Task_Allocations)) 5573 and then not Restriction_Active (No_Secondary_Stack) 5574 and then Has_Rep_Pragma 5575 (T, Name_Secondary_Stack_Size, Check_Parents => False); 5576 end Create_Secondary_Stack_For_Task; 5577 5578 ------------------------------------- 5579 -- Debug_Private_Data_Declarations -- 5580 ------------------------------------- 5581 5582 procedure Debug_Private_Data_Declarations (Decls : List_Id) is 5583 Debug_Nod : Node_Id; 5584 Decl : Node_Id; 5585 5586 begin 5587 Decl := First (Decls); 5588 while Present (Decl) and then not Comes_From_Source (Decl) loop 5589 5590 -- Declaration for concurrent entity _object and its access type, 5591 -- along with the entry index subtype: 5592 -- type prot_typVP is access prot_typV; 5593 -- _object : prot_typVP := prot_typV (_O); 5594 -- subtype Jnn is <Type of Index> range Low .. High; 5595 5596 if Nkind (Decl) in N_Full_Type_Declaration | N_Object_Declaration then 5597 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5598 5599 -- Declaration for the Protection object, discriminals, privals, and 5600 -- entry index constant: 5601 -- conc_typR : protection_typ renames _object._object; 5602 -- discr_nameD : discr_typ renames _object.discr_name; 5603 -- discr_nameD : discr_typ renames _task.discr_name; 5604 -- prival_name : comp_typ renames _object.comp_name; 5605 -- J : constant Jnn := 5606 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First)); 5607 5608 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 5609 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5610 Debug_Nod := Debug_Renaming_Declaration (Decl); 5611 5612 if Present (Debug_Nod) then 5613 Insert_After (Decl, Debug_Nod); 5614 end if; 5615 end if; 5616 5617 Next (Decl); 5618 end loop; 5619 end Debug_Private_Data_Declarations; 5620 5621 ------------------------------ 5622 -- Ensure_Statement_Present -- 5623 ------------------------------ 5624 5625 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is 5626 Stmt : Node_Id; 5627 5628 begin 5629 if Opt.Suppress_Control_Flow_Optimizations 5630 and then Is_Empty_List (Statements (Alt)) 5631 then 5632 Stmt := Make_Null_Statement (Loc); 5633 5634 -- Mark NULL statement as coming from source so that it is not 5635 -- eliminated by GIGI. 5636 5637 -- Another covert channel. If this is a requirement, it must be 5638 -- documented in sinfo/einfo ??? 5639 5640 Set_Comes_From_Source (Stmt, True); 5641 5642 Set_Statements (Alt, New_List (Stmt)); 5643 end if; 5644 end Ensure_Statement_Present; 5645 5646 ---------------------------- 5647 -- Entry_Index_Expression -- 5648 ---------------------------- 5649 5650 function Entry_Index_Expression 5651 (Sloc : Source_Ptr; 5652 Ent : Entity_Id; 5653 Index : Node_Id; 5654 Ttyp : Entity_Id) return Node_Id 5655 is 5656 Expr : Node_Id; 5657 Num : Node_Id; 5658 Lo : Node_Id; 5659 Hi : Node_Id; 5660 Prev : Entity_Id; 5661 S : Node_Id; 5662 5663 begin 5664 -- The queues of entries and entry families appear in textual order in 5665 -- the associated record. The entry index is computed as the sum of the 5666 -- number of queues for all entries that precede the designated one, to 5667 -- which is added the index expression, if this expression denotes a 5668 -- member of a family. 5669 5670 -- The following is a place holder for the count of simple entries 5671 5672 Num := Make_Integer_Literal (Sloc, 1); 5673 5674 -- We construct an expression which is a series of addition operations. 5675 -- The first operand is the number of single entries that precede this 5676 -- one, the second operand is the index value relative to the start of 5677 -- the referenced family, and the remaining operands are the lengths of 5678 -- the entry families that precede this entry, i.e. the constructed 5679 -- expression is: 5680 5681 -- number_simple_entries + 5682 -- (s'pos (index-value) - s'pos (family'first)) + 1 + 5683 -- family'length + ... 5684 5685 -- where index-value is the given index value, and s is the index 5686 -- subtype (we have to use pos because the subtype might be an 5687 -- enumeration type preventing direct subtraction). Note that the task 5688 -- entry array is one-indexed. 5689 5690 -- The upper bound of the entry family may be a discriminant, so we 5691 -- retrieve the lower bound explicitly to compute offset, rather than 5692 -- using the index subtype which may mention a discriminant. 5693 5694 if Present (Index) then 5695 S := Entry_Index_Type (Ent); 5696 5697 -- First make sure the index is in range if requested. The index type 5698 -- is the pristine Entry_Index_Type of the entry. 5699 5700 if Do_Range_Check (Index) then 5701 Generate_Range_Check (Index, S, CE_Range_Check_Failed); 5702 end if; 5703 5704 Expr := 5705 Make_Op_Add (Sloc, 5706 Left_Opnd => Num, 5707 Right_Opnd => 5708 Family_Offset 5709 (Sloc, 5710 Make_Attribute_Reference (Sloc, 5711 Attribute_Name => Name_Pos, 5712 Prefix => New_Occurrence_Of (Base_Type (S), Sloc), 5713 Expressions => New_List (Relocate_Node (Index))), 5714 Type_Low_Bound (S), 5715 Ttyp, 5716 False)); 5717 else 5718 Expr := Num; 5719 end if; 5720 5721 -- Now add lengths of preceding entries and entry families 5722 5723 Prev := First_Entity (Ttyp); 5724 while Chars (Prev) /= Chars (Ent) 5725 or else (Ekind (Prev) /= Ekind (Ent)) 5726 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 5727 loop 5728 if Ekind (Prev) = E_Entry then 5729 Set_Intval (Num, Intval (Num) + 1); 5730 5731 elsif Ekind (Prev) = E_Entry_Family then 5732 S := Entry_Index_Type (Prev); 5733 Lo := Type_Low_Bound (S); 5734 Hi := Type_High_Bound (S); 5735 5736 Expr := 5737 Make_Op_Add (Sloc, 5738 Left_Opnd => Expr, 5739 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False)); 5740 5741 -- Other components are anonymous types to be ignored 5742 5743 else 5744 null; 5745 end if; 5746 5747 Next_Entity (Prev); 5748 end loop; 5749 5750 return Expr; 5751 end Entry_Index_Expression; 5752 5753 --------------------------- 5754 -- Establish_Task_Master -- 5755 --------------------------- 5756 5757 procedure Establish_Task_Master (N : Node_Id) is 5758 Call : Node_Id; 5759 5760 begin 5761 if Restriction_Active (No_Task_Hierarchy) = False then 5762 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); 5763 5764 -- The block may have no declarations (and nevertheless be a task 5765 -- master) if it contains a call that may return an object that 5766 -- contains tasks. 5767 5768 if No (Declarations (N)) then 5769 Set_Declarations (N, New_List (Call)); 5770 else 5771 Prepend_To (Declarations (N), Call); 5772 end if; 5773 5774 Analyze (Call); 5775 end if; 5776 end Establish_Task_Master; 5777 5778 -------------------------------- 5779 -- Expand_Accept_Declarations -- 5780 -------------------------------- 5781 5782 -- Part of the expansion of an accept statement involves the creation of 5783 -- a declaration that can be referenced from the statement sequence of 5784 -- the accept: 5785 5786 -- Ann : Address; 5787 5788 -- This declaration is inserted immediately before the accept statement 5789 -- and it is important that it be inserted before the statements of the 5790 -- statement sequence are analyzed. Thus it would be too late to create 5791 -- this declaration in the Expand_N_Accept_Statement routine, which is 5792 -- why there is a separate procedure to be called directly from Sem_Ch9. 5793 5794 -- Ann is used to hold the address of the record containing the parameters 5795 -- (see Expand_N_Entry_Call for more details on how this record is built). 5796 -- References to the parameters do an unchecked conversion of this address 5797 -- to a pointer to the required record type, and then access the field that 5798 -- holds the value of the required parameter. The entity for the address 5799 -- variable is held as the top stack element (i.e. the last element) of the 5800 -- Accept_Address stack in the corresponding entry entity, and this element 5801 -- must be set in place before the statements are processed. 5802 5803 -- The above description applies to the case of a stand alone accept 5804 -- statement, i.e. one not appearing as part of a select alternative. 5805 5806 -- For the case of an accept that appears as part of a select alternative 5807 -- of a selective accept, we must still create the declaration right away, 5808 -- since Ann is needed immediately, but there is an important difference: 5809 5810 -- The declaration is inserted before the selective accept, not before 5811 -- the accept statement (which is not part of a list anyway, and so would 5812 -- not accommodate inserted declarations) 5813 5814 -- We only need one address variable for the entire selective accept. So 5815 -- the Ann declaration is created only for the first accept alternative, 5816 -- and subsequent accept alternatives reference the same Ann variable. 5817 5818 -- We can distinguish the two cases by seeing whether the accept statement 5819 -- is part of a list. If not, then it must be in an accept alternative. 5820 5821 -- To expand the requeue statement, a label is provided at the end of the 5822 -- accept statement or alternative of which it is a part, so that the 5823 -- statement can be skipped after the requeue is complete. This label is 5824 -- created here rather than during the expansion of the accept statement, 5825 -- because it will be needed by any requeue statements within the accept, 5826 -- which are expanded before the accept. 5827 5828 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is 5829 Loc : constant Source_Ptr := Sloc (N); 5830 Stats : constant Node_Id := Handled_Statement_Sequence (N); 5831 Ann : Entity_Id := Empty; 5832 Adecl : Node_Id; 5833 Lab : Node_Id; 5834 Ldecl : Node_Id; 5835 Ldecl2 : Node_Id; 5836 5837 begin 5838 if Expander_Active then 5839 5840 -- If we have no handled statement sequence, we may need to build 5841 -- a dummy sequence consisting of a null statement. This can be 5842 -- skipped if the trivial accept optimization is permitted. 5843 5844 if not Trivial_Accept_OK 5845 and then (No (Stats) or else Null_Statements (Statements (Stats))) 5846 then 5847 Set_Handled_Statement_Sequence (N, 5848 Make_Handled_Sequence_Of_Statements (Loc, 5849 Statements => New_List (Make_Null_Statement (Loc)))); 5850 end if; 5851 5852 -- Create and declare two labels to be placed at the end of the 5853 -- accept statement. The first label is used to allow requeues to 5854 -- skip the remainder of entry processing. The second label is used 5855 -- to skip the remainder of entry processing if the rendezvous 5856 -- completes in the middle of the accept body. 5857 5858 if Present (Handled_Statement_Sequence (N)) then 5859 declare 5860 Ent : Entity_Id; 5861 5862 begin 5863 Ent := Make_Temporary (Loc, 'L'); 5864 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 5865 Ldecl := 5866 Make_Implicit_Label_Declaration (Loc, 5867 Defining_Identifier => Ent, 5868 Label_Construct => Lab); 5869 Append (Lab, Statements (Handled_Statement_Sequence (N))); 5870 5871 Ent := Make_Temporary (Loc, 'L'); 5872 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 5873 Ldecl2 := 5874 Make_Implicit_Label_Declaration (Loc, 5875 Defining_Identifier => Ent, 5876 Label_Construct => Lab); 5877 Append (Lab, Statements (Handled_Statement_Sequence (N))); 5878 end; 5879 5880 else 5881 Ldecl := Empty; 5882 Ldecl2 := Empty; 5883 end if; 5884 5885 -- Case of stand alone accept statement 5886 5887 if Is_List_Member (N) then 5888 5889 if Present (Handled_Statement_Sequence (N)) then 5890 Ann := Make_Temporary (Loc, 'A'); 5891 5892 Adecl := 5893 Make_Object_Declaration (Loc, 5894 Defining_Identifier => Ann, 5895 Object_Definition => 5896 New_Occurrence_Of (RTE (RE_Address), Loc)); 5897 5898 Insert_Before_And_Analyze (N, Adecl); 5899 Insert_Before_And_Analyze (N, Ldecl); 5900 Insert_Before_And_Analyze (N, Ldecl2); 5901 end if; 5902 5903 -- Case of accept statement which is in an accept alternative 5904 5905 else 5906 declare 5907 Acc_Alt : constant Node_Id := Parent (N); 5908 Sel_Acc : constant Node_Id := Parent (Acc_Alt); 5909 Alt : Node_Id; 5910 5911 begin 5912 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative); 5913 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept); 5914 5915 -- ??? Consider a single label for select statements 5916 5917 if Present (Handled_Statement_Sequence (N)) then 5918 Prepend (Ldecl2, 5919 Statements (Handled_Statement_Sequence (N))); 5920 Analyze (Ldecl2); 5921 5922 Prepend (Ldecl, 5923 Statements (Handled_Statement_Sequence (N))); 5924 Analyze (Ldecl); 5925 end if; 5926 5927 -- Find first accept alternative of the selective accept. A 5928 -- valid selective accept must have at least one accept in it. 5929 5930 Alt := First (Select_Alternatives (Sel_Acc)); 5931 5932 while Nkind (Alt) /= N_Accept_Alternative loop 5933 Next (Alt); 5934 end loop; 5935 5936 -- If this is the first accept statement, then we have to 5937 -- create the Ann variable, as for the stand alone case, except 5938 -- that it is inserted before the selective accept. Similarly, 5939 -- a label for requeue expansion must be declared. 5940 5941 if N = Accept_Statement (Alt) then 5942 Ann := Make_Temporary (Loc, 'A'); 5943 Adecl := 5944 Make_Object_Declaration (Loc, 5945 Defining_Identifier => Ann, 5946 Object_Definition => 5947 New_Occurrence_Of (RTE (RE_Address), Loc)); 5948 5949 Insert_Before_And_Analyze (Sel_Acc, Adecl); 5950 5951 -- If this is not the first accept statement, then find the Ann 5952 -- variable allocated by the first accept and use it. 5953 5954 else 5955 Ann := 5956 Node (Last_Elmt (Accept_Address 5957 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))))); 5958 end if; 5959 end; 5960 end if; 5961 5962 -- Merge here with Ann either created or referenced, and Adecl 5963 -- pointing to the corresponding declaration. Remaining processing 5964 -- is the same for the two cases. 5965 5966 if Present (Ann) then 5967 Append_Elmt (Ann, Accept_Address (Ent)); 5968 Set_Debug_Info_Needed (Ann); 5969 end if; 5970 5971 -- Create renaming declarations for the entry formals. Each reference 5972 -- to a formal becomes a dereference of a component of the parameter 5973 -- block, whose address is held in Ann. These declarations are 5974 -- eventually inserted into the accept block, and analyzed there so 5975 -- that they have the proper scope for gdb and do not conflict with 5976 -- other declarations. 5977 5978 if Present (Parameter_Specifications (N)) 5979 and then Present (Handled_Statement_Sequence (N)) 5980 then 5981 declare 5982 Comp : Entity_Id; 5983 Decl : Node_Id; 5984 Formal : Entity_Id; 5985 New_F : Entity_Id; 5986 Renamed_Formal : Node_Id; 5987 5988 begin 5989 Push_Scope (Ent); 5990 Formal := First_Formal (Ent); 5991 5992 while Present (Formal) loop 5993 Comp := Entry_Component (Formal); 5994 New_F := Make_Defining_Identifier (Loc, Chars (Formal)); 5995 5996 Set_Etype (New_F, Etype (Formal)); 5997 Set_Scope (New_F, Ent); 5998 5999 -- Now we set debug info needed on New_F even though it does 6000 -- not come from source, so that the debugger will get the 6001 -- right information for these generated names. 6002 6003 Set_Debug_Info_Needed (New_F); 6004 6005 if Ekind (Formal) = E_In_Parameter then 6006 Set_Ekind (New_F, E_Constant); 6007 else 6008 Set_Ekind (New_F, E_Variable); 6009 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 6010 end if; 6011 6012 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 6013 6014 Renamed_Formal := 6015 Make_Selected_Component (Loc, 6016 Prefix => 6017 Make_Explicit_Dereference (Loc, 6018 Unchecked_Convert_To ( 6019 Entry_Parameters_Type (Ent), 6020 New_Occurrence_Of (Ann, Loc))), 6021 Selector_Name => 6022 New_Occurrence_Of (Comp, Loc)); 6023 6024 Decl := 6025 Build_Renamed_Formal_Declaration 6026 (New_F, Formal, Comp, Renamed_Formal); 6027 6028 if No (Declarations (N)) then 6029 Set_Declarations (N, New_List); 6030 end if; 6031 6032 Append (Decl, Declarations (N)); 6033 Set_Renamed_Object (Formal, New_F); 6034 Next_Formal (Formal); 6035 end loop; 6036 6037 End_Scope; 6038 end; 6039 end if; 6040 end if; 6041 end Expand_Accept_Declarations; 6042 6043 --------------------------------------------- 6044 -- Expand_Access_Protected_Subprogram_Type -- 6045 --------------------------------------------- 6046 6047 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is 6048 Loc : constant Source_Ptr := Sloc (N); 6049 T : constant Entity_Id := Defining_Identifier (N); 6050 D_T : constant Entity_Id := Designated_Type (T); 6051 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D'); 6052 E_T : constant Entity_Id := Make_Temporary (Loc, 'E'); 6053 P_List : constant List_Id := 6054 Build_Protected_Spec (N, RTE (RE_Address), D_T, False); 6055 6056 Comps : List_Id; 6057 Decl1 : Node_Id; 6058 Decl2 : Node_Id; 6059 Def1 : Node_Id; 6060 6061 begin 6062 -- Create access to subprogram with full signature 6063 6064 if Etype (D_T) /= Standard_Void_Type then 6065 Def1 := 6066 Make_Access_Function_Definition (Loc, 6067 Parameter_Specifications => P_List, 6068 Result_Definition => 6069 Copy_Result_Type (Result_Definition (Type_Definition (N)))); 6070 6071 else 6072 Def1 := 6073 Make_Access_Procedure_Definition (Loc, 6074 Parameter_Specifications => P_List); 6075 end if; 6076 6077 Decl1 := 6078 Make_Full_Type_Declaration (Loc, 6079 Defining_Identifier => D_T2, 6080 Type_Definition => Def1); 6081 6082 -- Declare the new types before the original one since the latter will 6083 -- refer to them through the Equivalent_Type slot. 6084 6085 Insert_Before_And_Analyze (N, Decl1); 6086 6087 -- Associate the access to subprogram with its original access to 6088 -- protected subprogram type. Needed by the backend to know that this 6089 -- type corresponds with an access to protected subprogram type. 6090 6091 Set_Original_Access_Type (D_T2, T); 6092 6093 -- Create Equivalent_Type, a record with two components for an access to 6094 -- object and an access to subprogram. 6095 6096 Comps := New_List ( 6097 Make_Component_Declaration (Loc, 6098 Defining_Identifier => Make_Temporary (Loc, 'P'), 6099 Component_Definition => 6100 Make_Component_Definition (Loc, 6101 Aliased_Present => False, 6102 Subtype_Indication => 6103 New_Occurrence_Of (RTE (RE_Address), Loc))), 6104 6105 Make_Component_Declaration (Loc, 6106 Defining_Identifier => Make_Temporary (Loc, 'S'), 6107 Component_Definition => 6108 Make_Component_Definition (Loc, 6109 Aliased_Present => False, 6110 Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); 6111 6112 Decl2 := 6113 Make_Full_Type_Declaration (Loc, 6114 Defining_Identifier => E_T, 6115 Type_Definition => 6116 Make_Record_Definition (Loc, 6117 Component_List => 6118 Make_Component_List (Loc, Component_Items => Comps))); 6119 6120 Insert_Before_And_Analyze (N, Decl2); 6121 Set_Equivalent_Type (T, E_T); 6122 end Expand_Access_Protected_Subprogram_Type; 6123 6124 -------------------------- 6125 -- Expand_Entry_Barrier -- 6126 -------------------------- 6127 6128 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is 6129 Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N)); 6130 Prot : constant Entity_Id := Scope (Ent); 6131 Spec_Decl : constant Node_Id := Parent (Prot); 6132 6133 Func_Id : Entity_Id := Empty; 6134 -- The entity of the barrier function 6135 6136 function Is_Global_Entity (N : Node_Id) return Traverse_Result; 6137 -- Check whether entity in Barrier is external to protected type. 6138 -- If so, barrier may not be properly synchronized. 6139 6140 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result; 6141 -- Check whether N meets the Pure_Barriers restriction. Return OK if 6142 -- so. 6143 6144 function Is_Simple_Barrier (N : Node_Id) return Boolean; 6145 -- Check whether N meets the Simple_Barriers restriction. Return OK if 6146 -- so. 6147 6148 ---------------------- 6149 -- Is_Global_Entity -- 6150 ---------------------- 6151 6152 function Is_Global_Entity (N : Node_Id) return Traverse_Result is 6153 E : Entity_Id; 6154 S : Entity_Id; 6155 6156 begin 6157 if Is_Entity_Name (N) and then Present (Entity (N)) then 6158 E := Entity (N); 6159 S := Scope (E); 6160 6161 if Ekind (E) = E_Variable then 6162 6163 -- If the variable is local to the barrier function generated 6164 -- during expansion, it is ok. If expansion is not performed, 6165 -- then Func is Empty so this test cannot succeed. 6166 6167 if Scope (E) = Func_Id then 6168 null; 6169 6170 -- A protected call from a barrier to another object is ok 6171 6172 elsif Ekind (Etype (E)) = E_Protected_Type then 6173 null; 6174 6175 -- If the variable is within the package body we consider 6176 -- this safe. This is a common (if dubious) idiom. 6177 6178 elsif S = Scope (Prot) 6179 and then Is_Package_Or_Generic_Package (S) 6180 and then Nkind (Parent (E)) = N_Object_Declaration 6181 and then Nkind (Parent (Parent (E))) = N_Package_Body 6182 then 6183 null; 6184 6185 else 6186 Error_Msg_N ("potentially unsynchronized barrier??", N); 6187 Error_Msg_N ("\& should be private component of type??", N); 6188 end if; 6189 end if; 6190 end if; 6191 6192 return OK; 6193 end Is_Global_Entity; 6194 6195 procedure Check_Unprotected_Barrier is 6196 new Traverse_Proc (Is_Global_Entity); 6197 6198 ----------------------- 6199 -- Is_Simple_Barrier -- 6200 ----------------------- 6201 6202 function Is_Simple_Barrier (N : Node_Id) return Boolean is 6203 Renamed : Node_Id; 6204 6205 begin 6206 if Is_Static_Expression (N) then 6207 return True; 6208 elsif Ada_Version >= Ada_2020 6209 and then Nkind (N) in N_Selected_Component | N_Indexed_Component 6210 and then Statically_Names_Object (N) 6211 then 6212 -- Restriction relaxed in Ada2020 to allow statically named 6213 -- subcomponents. 6214 return Is_Simple_Barrier (Prefix (N)); 6215 end if; 6216 6217 -- Check if the name is a component of the protected object. If 6218 -- the expander is active, the component has been transformed into a 6219 -- renaming of _object.all.component. Original_Node is needed in case 6220 -- validity checking is enabled, in which case the simple object 6221 -- reference will have been rewritten. 6222 6223 if Expander_Active then 6224 6225 -- The expanded name may have been constant folded in which case 6226 -- the original node is not necessarily an entity name (e.g. an 6227 -- indexed component). 6228 6229 if not Is_Entity_Name (Original_Node (N)) then 6230 return False; 6231 end if; 6232 6233 Renamed := Renamed_Object (Entity (Original_Node (N))); 6234 6235 return 6236 Present (Renamed) 6237 and then Nkind (Renamed) = N_Selected_Component 6238 and then Chars (Prefix (Prefix (Renamed))) = Name_uObject; 6239 elsif not Is_Entity_Name (N) then 6240 return False; 6241 else 6242 return Is_Protected_Component (Entity (N)); 6243 end if; 6244 end Is_Simple_Barrier; 6245 6246 --------------------- 6247 -- Is_Pure_Barrier -- 6248 --------------------- 6249 6250 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is 6251 begin 6252 case Nkind (N) is 6253 when N_Expanded_Name 6254 | N_Identifier 6255 => 6256 6257 -- Because of N_Expanded_Name case, return Skip instead of OK. 6258 6259 if No (Entity (N)) then 6260 return Abandon; 6261 6262 elsif Is_Numeric_Type (Entity (N)) then 6263 return Skip; 6264 end if; 6265 6266 case Ekind (Entity (N)) is 6267 when E_Constant 6268 | E_Discriminant 6269 => 6270 return Skip; 6271 6272 when E_Enumeration_Literal 6273 | E_Named_Integer 6274 | E_Named_Real 6275 => 6276 if not Is_OK_Static_Expression (N) then 6277 return Abandon; 6278 end if; 6279 return Skip; 6280 6281 when E_Component => 6282 return Skip; 6283 6284 when E_Variable => 6285 if Is_Simple_Barrier (N) then 6286 return Skip; 6287 end if; 6288 6289 when E_Function => 6290 6291 -- The count attribute has been transformed into run-time 6292 -- calls. 6293 6294 if Is_RTE (Entity (N), RE_Protected_Count) 6295 or else Is_RTE (Entity (N), RE_Protected_Count_Entry) 6296 then 6297 return Skip; 6298 end if; 6299 6300 when others => 6301 null; 6302 end case; 6303 6304 when N_Function_Call => 6305 6306 -- Function call checks are carried out as part of the analysis 6307 -- of the function call name. 6308 6309 return OK; 6310 6311 when N_Character_Literal 6312 | N_Integer_Literal 6313 | N_Real_Literal 6314 => 6315 return OK; 6316 6317 when N_Op_Boolean 6318 | N_Op_Not 6319 => 6320 if Ekind (Entity (N)) = E_Operator then 6321 return OK; 6322 end if; 6323 6324 when N_Short_Circuit 6325 | N_If_Expression 6326 | N_Case_Expression 6327 => 6328 return OK; 6329 6330 when N_Indexed_Component | N_Selected_Component => 6331 if Statically_Names_Object (N) then 6332 return Is_Pure_Barrier (Prefix (N)); 6333 else 6334 return Abandon; 6335 end if; 6336 6337 when N_Case_Expression_Alternative => 6338 -- do not traverse Discrete_Choices subtree 6339 if Is_Pure_Barrier (Expression (N)) /= Abandon then 6340 return Skip; 6341 end if; 6342 6343 when N_Expression_With_Actions => 6344 -- this may occur in the case of a Count attribute reference 6345 if Original_Node (N) /= N 6346 and then Is_Pure_Barrier (Original_Node (N)) /= Abandon 6347 then 6348 return Skip; 6349 end if; 6350 6351 when N_Membership_Test => 6352 if Is_Pure_Barrier (Left_Opnd (N)) /= Abandon 6353 and then All_Membership_Choices_Static (N) 6354 then 6355 return Skip; 6356 end if; 6357 6358 when N_Type_Conversion => 6359 6360 -- Conversions to Universal_Integer do not raise constraint 6361 -- errors. Likewise if the expression's type is statically 6362 -- compatible with the target's type. 6363 6364 if Etype (N) = Universal_Integer 6365 or else Subtypes_Statically_Compatible 6366 (Etype (Expression (N)), Etype (N)) 6367 then 6368 return OK; 6369 end if; 6370 6371 when N_Unchecked_Type_Conversion => 6372 return OK; 6373 6374 when others => 6375 null; 6376 end case; 6377 6378 return Abandon; 6379 end Is_Pure_Barrier; 6380 6381 function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier); 6382 6383 -- Local variables 6384 6385 Cond_Id : Entity_Id; 6386 Entry_Body : Node_Id; 6387 Func_Body : Node_Id := Empty; 6388 6389 -- Start of processing for Expand_Entry_Barrier 6390 6391 begin 6392 if No_Run_Time_Mode then 6393 Error_Msg_CRT ("entry barrier", N); 6394 return; 6395 end if; 6396 6397 -- Prevent cascaded errors 6398 6399 if Nkind (Cond) = N_Error then 6400 return; 6401 end if; 6402 6403 -- The body of the entry barrier must be analyzed in the context of the 6404 -- protected object, but its scope is external to it, just as any other 6405 -- unprotected version of a protected operation. The specification has 6406 -- been produced when the protected type declaration was elaborated. We 6407 -- build the body, insert it in the enclosing scope, but analyze it in 6408 -- the current context. A more uniform approach would be to treat the 6409 -- barrier just as a protected function, and discard the protected 6410 -- version of it because it is never called. 6411 6412 if Expander_Active then 6413 Func_Body := Build_Barrier_Function (N, Ent, Prot); 6414 Func_Id := Barrier_Function (Ent); 6415 Set_Corresponding_Spec (Func_Body, Func_Id); 6416 6417 Entry_Body := Parent (Corresponding_Body (Spec_Decl)); 6418 6419 if Nkind (Parent (Entry_Body)) = N_Subunit then 6420 Entry_Body := Corresponding_Stub (Parent (Entry_Body)); 6421 end if; 6422 6423 Insert_Before_And_Analyze (Entry_Body, Func_Body); 6424 6425 Set_Discriminals (Spec_Decl); 6426 Set_Scope (Func_Id, Scope (Prot)); 6427 6428 else 6429 Analyze_And_Resolve (Cond, Any_Boolean); 6430 end if; 6431 6432 -- Check Simple_Barriers and Pure_Barriers restrictions. 6433 -- Note that it is safe to be calling Check_Restriction from here, even 6434 -- though this is part of the expander, since Expand_Entry_Barrier is 6435 -- called from Sem_Ch9 even in -gnatc mode. 6436 6437 if not Is_Simple_Barrier (Cond) then 6438 -- flag restriction violation 6439 Check_Restriction (Simple_Barriers, Cond); 6440 end if; 6441 6442 if Check_Pure_Barriers (Cond) = Abandon then 6443 -- flag restriction violation 6444 Check_Restriction (Pure_Barriers, Cond); 6445 6446 -- Emit warning if barrier contains global entities and is thus 6447 -- potentially unsynchronized (if Pure_Barriers restrictions 6448 -- are met then no need to check for this). 6449 Check_Unprotected_Barrier (Cond); 6450 end if; 6451 6452 if Is_Entity_Name (Cond) then 6453 Cond_Id := Entity (Cond); 6454 6455 -- Perform a small optimization of simple barrier functions. If the 6456 -- scope of the condition's entity is not the barrier function, then 6457 -- the condition does not depend on any of the generated renamings. 6458 -- If this is the case, eliminate the renamings as they are useless. 6459 -- This optimization is not performed when the condition was folded 6460 -- and validity checks are in effect because the original condition 6461 -- may have produced at least one check that depends on the generated 6462 -- renamings. 6463 6464 if Expander_Active 6465 and then Scope (Cond_Id) /= Func_Id 6466 and then not Validity_Check_Operands 6467 then 6468 Set_Declarations (Func_Body, Empty_List); 6469 end if; 6470 6471 -- Note that after analysis variables in this context will be 6472 -- replaced by the corresponding prival, that is to say a renaming 6473 -- of a selected component of the form _Object.Var. If expansion is 6474 -- disabled, as within a generic, we check that the entity appears in 6475 -- the current scope. 6476 end if; 6477 end Expand_Entry_Barrier; 6478 6479 ------------------------------ 6480 -- Expand_N_Abort_Statement -- 6481 ------------------------------ 6482 6483 -- Expand abort T1, T2, .. Tn; into: 6484 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...)) 6485 6486 procedure Expand_N_Abort_Statement (N : Node_Id) is 6487 Loc : constant Source_Ptr := Sloc (N); 6488 Tlist : constant List_Id := Names (N); 6489 Count : Nat; 6490 Aggr : Node_Id; 6491 Tasknm : Node_Id; 6492 6493 begin 6494 Aggr := Make_Aggregate (Loc, Component_Associations => New_List); 6495 Count := 0; 6496 6497 Tasknm := First (Tlist); 6498 6499 while Present (Tasknm) loop 6500 Count := Count + 1; 6501 6502 -- A task interface class-wide type object is being aborted. Retrieve 6503 -- its _task_id by calling a dispatching routine. 6504 6505 if Ada_Version >= Ada_2005 6506 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type 6507 and then Is_Interface (Etype (Tasknm)) 6508 and then Is_Task_Interface (Etype (Tasknm)) 6509 then 6510 Append_To (Component_Associations (Aggr), 6511 Make_Component_Association (Loc, 6512 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6513 Expression => 6514 6515 -- Task_Id (Tasknm._disp_get_task_id) 6516 6517 Make_Unchecked_Type_Conversion (Loc, 6518 Subtype_Mark => 6519 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 6520 Expression => 6521 Make_Selected_Component (Loc, 6522 Prefix => New_Copy_Tree (Tasknm), 6523 Selector_Name => 6524 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))); 6525 6526 else 6527 Append_To (Component_Associations (Aggr), 6528 Make_Component_Association (Loc, 6529 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6530 Expression => Concurrent_Ref (Tasknm))); 6531 end if; 6532 6533 Next (Tasknm); 6534 end loop; 6535 6536 Rewrite (N, 6537 Make_Procedure_Call_Statement (Loc, 6538 Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc), 6539 Parameter_Associations => New_List ( 6540 Make_Qualified_Expression (Loc, 6541 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_List), Loc), 6542 Expression => Aggr)))); 6543 6544 Analyze (N); 6545 end Expand_N_Abort_Statement; 6546 6547 ------------------------------- 6548 -- Expand_N_Accept_Statement -- 6549 ------------------------------- 6550 6551 -- This procedure handles expansion of accept statements that stand alone, 6552 -- i.e. they are not part of an accept alternative. The expansion of 6553 -- accept statement in accept alternatives is handled by the routines 6554 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The 6555 -- following description applies only to stand alone accept statements. 6556 6557 -- If there is no handled statement sequence, or only null statements, then 6558 -- this is called a trivial accept, and the expansion is: 6559 6560 -- Accept_Trivial (entry-index) 6561 6562 -- If there is a handled statement sequence, then the expansion is: 6563 6564 -- Ann : Address; 6565 -- {Lnn : Label} 6566 6567 -- begin 6568 -- begin 6569 -- Accept_Call (entry-index, Ann); 6570 -- Renaming_Declarations for formals 6571 -- <statement sequence from N_Accept_Statement node> 6572 -- Complete_Rendezvous; 6573 -- <<Lnn>> 6574 -- 6575 -- exception 6576 -- when ... => 6577 -- <exception handler from N_Accept_Statement node> 6578 -- Complete_Rendezvous; 6579 -- when ... => 6580 -- <exception handler from N_Accept_Statement node> 6581 -- Complete_Rendezvous; 6582 -- ... 6583 -- end; 6584 6585 -- exception 6586 -- when all others => 6587 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 6588 -- end; 6589 6590 -- The first three declarations were already inserted ahead of the accept 6591 -- statement by the Expand_Accept_Declarations procedure, which was called 6592 -- directly from the semantics during analysis of the accept statement, 6593 -- before analyzing its contained statements. 6594 6595 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come 6596 -- from possible expansion activity (the original source of course does 6597 -- not have any declarations associated with the accept statement, since 6598 -- an accept statement has no declarative part). In particular, if the 6599 -- expander is active, the first such declaration is the declaration of 6600 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement). 6601 6602 -- The two blocks are merged into a single block if the inner block has 6603 -- no exception handlers, but otherwise two blocks are required, since 6604 -- exceptions might be raised in the exception handlers of the inner 6605 -- block, and Exceptional_Complete_Rendezvous must be called. 6606 6607 procedure Expand_N_Accept_Statement (N : Node_Id) is 6608 Loc : constant Source_Ptr := Sloc (N); 6609 Stats : constant Node_Id := Handled_Statement_Sequence (N); 6610 Ename : constant Node_Id := Entry_Direct_Name (N); 6611 Eindx : constant Node_Id := Entry_Index (N); 6612 Eent : constant Entity_Id := Entity (Ename); 6613 Acstack : constant Elist_Id := Accept_Address (Eent); 6614 Ann : constant Entity_Id := Node (Last_Elmt (Acstack)); 6615 Ttyp : constant Entity_Id := Etype (Scope (Eent)); 6616 Blkent : Entity_Id; 6617 Call : Node_Id; 6618 Block : Node_Id; 6619 6620 begin 6621 -- If the accept statement is not part of a list, then its parent must 6622 -- be an accept alternative, and, as described above, we do not do any 6623 -- expansion for such accept statements at this level. 6624 6625 if not Is_List_Member (N) then 6626 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative); 6627 return; 6628 6629 -- Trivial accept case (no statement sequence, or null statements). 6630 -- If the accept statement has declarations, then just insert them 6631 -- before the procedure call. 6632 6633 elsif Trivial_Accept_OK 6634 and then (No (Stats) or else Null_Statements (Statements (Stats))) 6635 then 6636 -- Remove declarations for renamings, because the parameter block 6637 -- will not be assigned. 6638 6639 declare 6640 D : Node_Id; 6641 Next_D : Node_Id; 6642 6643 begin 6644 D := First (Declarations (N)); 6645 while Present (D) loop 6646 Next_D := Next (D); 6647 if Nkind (D) = N_Object_Renaming_Declaration then 6648 Remove (D); 6649 end if; 6650 6651 D := Next_D; 6652 end loop; 6653 end; 6654 6655 if Present (Declarations (N)) then 6656 Insert_Actions (N, Declarations (N)); 6657 end if; 6658 6659 Rewrite (N, 6660 Make_Procedure_Call_Statement (Loc, 6661 Name => New_Occurrence_Of (RTE (RE_Accept_Trivial), Loc), 6662 Parameter_Associations => New_List ( 6663 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp)))); 6664 6665 Analyze (N); 6666 6667 -- Ada 2020 (AI12-0279) 6668 6669 if Has_Yield_Aspect (Eent) 6670 and then RTE_Available (RE_Yield) 6671 then 6672 Insert_Action_After (N, 6673 Make_Procedure_Call_Statement (Loc, 6674 New_Occurrence_Of (RTE (RE_Yield), Loc))); 6675 end if; 6676 6677 -- Discard Entry_Address that was created for it, so it will not be 6678 -- emitted if this accept statement is in the statement part of a 6679 -- delay alternative. 6680 6681 if Present (Stats) then 6682 Remove_Last_Elmt (Acstack); 6683 end if; 6684 6685 -- Case of statement sequence present 6686 6687 else 6688 -- Construct the block, using the declarations from the accept 6689 -- statement if any to initialize the declarations of the block. 6690 6691 Blkent := Make_Temporary (Loc, 'A'); 6692 Set_Ekind (Blkent, E_Block); 6693 Set_Etype (Blkent, Standard_Void_Type); 6694 Set_Scope (Blkent, Current_Scope); 6695 6696 Block := 6697 Make_Block_Statement (Loc, 6698 Identifier => New_Occurrence_Of (Blkent, Loc), 6699 Declarations => Declarations (N), 6700 Handled_Statement_Sequence => Build_Accept_Body (N)); 6701 6702 -- Reset the Scope of local entities associated with the accept 6703 -- statement (that currently reference the entry scope) to the 6704 -- block scope, to avoid having references to the locals treated 6705 -- as up-level references. 6706 6707 Reset_Scopes_To (Block, Blkent); 6708 6709 -- For the analysis of the generated declarations, the parent node 6710 -- must be properly set. 6711 6712 Set_Parent (Block, Parent (N)); 6713 Set_Parent (Blkent, Block); 6714 6715 -- Prepend call to Accept_Call to main statement sequence If the 6716 -- accept has exception handlers, the statement sequence is wrapped 6717 -- in a block. Insert call and renaming declarations in the 6718 -- declarations of the block, so they are elaborated before the 6719 -- handlers. 6720 6721 Call := 6722 Make_Procedure_Call_Statement (Loc, 6723 Name => New_Occurrence_Of (RTE (RE_Accept_Call), Loc), 6724 Parameter_Associations => New_List ( 6725 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp), 6726 New_Occurrence_Of (Ann, Loc))); 6727 6728 if Parent (Stats) = N then 6729 Prepend (Call, Statements (Stats)); 6730 else 6731 Set_Declarations (Parent (Stats), New_List (Call)); 6732 end if; 6733 6734 Analyze (Call); 6735 6736 Push_Scope (Blkent); 6737 6738 declare 6739 D : Node_Id; 6740 Next_D : Node_Id; 6741 Typ : Entity_Id; 6742 6743 begin 6744 D := First (Declarations (N)); 6745 while Present (D) loop 6746 Next_D := Next (D); 6747 6748 if Nkind (D) = N_Object_Renaming_Declaration then 6749 6750 -- The renaming declarations for the formals were created 6751 -- during analysis of the accept statement, and attached to 6752 -- the list of declarations. Place them now in the context 6753 -- of the accept block or subprogram. 6754 6755 Remove (D); 6756 Typ := Entity (Subtype_Mark (D)); 6757 Insert_After (Call, D); 6758 Analyze (D); 6759 6760 -- If the formal is class_wide, it does not have an actual 6761 -- subtype. The analysis of the renaming declaration creates 6762 -- one, but we need to retain the class-wide nature of the 6763 -- entity. 6764 6765 if Is_Class_Wide_Type (Typ) then 6766 Set_Etype (Defining_Identifier (D), Typ); 6767 end if; 6768 6769 end if; 6770 6771 D := Next_D; 6772 end loop; 6773 end; 6774 6775 End_Scope; 6776 6777 -- Replace the accept statement by the new block 6778 6779 Rewrite (N, Block); 6780 Analyze (N); 6781 6782 -- Last step is to unstack the Accept_Address value 6783 6784 Remove_Last_Elmt (Acstack); 6785 end if; 6786 end Expand_N_Accept_Statement; 6787 6788 ---------------------------------- 6789 -- Expand_N_Asynchronous_Select -- 6790 ---------------------------------- 6791 6792 -- This procedure assumes that the trigger statement is an entry call or 6793 -- a dispatching procedure call. A delay alternative should already have 6794 -- been expanded into an entry call to the appropriate delay object Wait 6795 -- entry. 6796 6797 -- If the trigger is a task entry call, the select is implemented with 6798 -- a Task_Entry_Call: 6799 6800 -- declare 6801 -- B : Boolean; 6802 -- C : Boolean; 6803 -- P : parms := (parm, parm, parm); 6804 6805 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6806 6807 -- procedure _clean is 6808 -- begin 6809 -- ... 6810 -- Cancel_Task_Entry_Call (C); 6811 -- ... 6812 -- end _clean; 6813 6814 -- begin 6815 -- Abort_Defer; 6816 -- Task_Entry_Call 6817 -- (<acceptor-task>, -- Acceptor 6818 -- <entry-index>, -- E 6819 -- P'Address, -- Uninterpreted_Data 6820 -- Asynchronous_Call, -- Mode 6821 -- B); -- Rendezvous_Successful 6822 6823 -- begin 6824 -- begin 6825 -- Abort_Undefer; 6826 -- <abortable-part> 6827 -- at end 6828 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6829 -- end; 6830 -- exception 6831 -- when Abort_Signal => Abort_Undefer; 6832 -- end; 6833 6834 -- parm := P.param; 6835 -- parm := P.param; 6836 -- ... 6837 -- if not C then 6838 -- <triggered-statements> 6839 -- end if; 6840 -- end; 6841 6842 -- Note that Build_Simple_Entry_Call is used to expand the entry of the 6843 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure) 6844 -- as follows: 6845 6846 -- declare 6847 -- P : parms := (parm, parm, parm); 6848 -- begin 6849 -- Call_Simple (acceptor-task, entry-index, P'Address); 6850 -- parm := P.param; 6851 -- parm := P.param; 6852 -- ... 6853 -- end; 6854 6855 -- so the task at hand is to convert the latter expansion into the former 6856 6857 -- If the trigger is a protected entry call, the select is implemented 6858 -- with Protected_Entry_Call: 6859 6860 -- declare 6861 -- P : E1_Params := (param, param, param); 6862 -- Bnn : Communications_Block; 6863 6864 -- begin 6865 -- declare 6866 6867 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6868 6869 -- procedure _clean is 6870 -- begin 6871 -- ... 6872 -- if Enqueued (Bnn) then 6873 -- Cancel_Protected_Entry_Call (Bnn); 6874 -- end if; 6875 -- ... 6876 -- end _clean; 6877 6878 -- begin 6879 -- begin 6880 -- Protected_Entry_Call 6881 -- (po._object'Access, -- Object 6882 -- <entry index>, -- E 6883 -- P'Address, -- Uninterpreted_Data 6884 -- Asynchronous_Call, -- Mode 6885 -- Bnn); -- Block 6886 6887 -- if Enqueued (Bnn) then 6888 -- <abortable-part> 6889 -- end if; 6890 -- at end 6891 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6892 -- end; 6893 -- exception 6894 -- when Abort_Signal => Abort_Undefer; 6895 -- end; 6896 6897 -- if not Cancelled (Bnn) then 6898 -- <triggered-statements> 6899 -- end if; 6900 -- end; 6901 6902 -- Build_Simple_Entry_Call is used to expand the all to a simple protected 6903 -- entry call: 6904 6905 -- declare 6906 -- P : E1_Params := (param, param, param); 6907 -- Bnn : Communications_Block; 6908 6909 -- begin 6910 -- Protected_Entry_Call 6911 -- (po._object'Access, -- Object 6912 -- <entry index>, -- E 6913 -- P'Address, -- Uninterpreted_Data 6914 -- Simple_Call, -- Mode 6915 -- Bnn); -- Block 6916 -- parm := P.param; 6917 -- parm := P.param; 6918 -- ... 6919 -- end; 6920 6921 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is 6922 -- expanded into: 6923 6924 -- declare 6925 -- B : Boolean := False; 6926 -- Bnn : Communication_Block; 6927 -- C : Ada.Tags.Prim_Op_Kind; 6928 -- D : System.Storage_Elements.Dummy_Communication_Block; 6929 -- K : Ada.Tags.Tagged_Kind := 6930 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 6931 -- P : Parameters := (Param1 .. ParamN); 6932 -- S : Integer; 6933 -- U : Boolean; 6934 6935 -- begin 6936 -- if K = Ada.Tags.TK_Limited_Tagged 6937 -- or else K = Ada.Tags.TK_Tagged 6938 -- then 6939 -- <dispatching-call>; 6940 -- <triggering-statements>; 6941 6942 -- else 6943 -- S := 6944 -- Ada.Tags.Get_Offset_Index 6945 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 6946 6947 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 6948 6949 -- if C = POK_Protected_Entry then 6950 -- declare 6951 -- procedure _clean is 6952 -- begin 6953 -- if Enqueued (Bnn) then 6954 -- Cancel_Protected_Entry_Call (Bnn); 6955 -- end if; 6956 -- end _clean; 6957 6958 -- begin 6959 -- begin 6960 -- _Disp_Asynchronous_Select 6961 -- (<object>, S, P'Address, D, B); 6962 -- Bnn := Communication_Block (D); 6963 6964 -- Param1 := P.Param1; 6965 -- ... 6966 -- ParamN := P.ParamN; 6967 6968 -- if Enqueued (Bnn) then 6969 -- <abortable-statements> 6970 -- end if; 6971 -- at end 6972 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6973 -- end; 6974 -- exception 6975 -- when Abort_Signal => Abort_Undefer; 6976 -- end; 6977 6978 -- if not Cancelled (Bnn) then 6979 -- <triggering-statements> 6980 -- end if; 6981 6982 -- elsif C = POK_Task_Entry then 6983 -- declare 6984 -- procedure _clean is 6985 -- begin 6986 -- Cancel_Task_Entry_Call (U); 6987 -- end _clean; 6988 6989 -- begin 6990 -- Abort_Defer; 6991 6992 -- _Disp_Asynchronous_Select 6993 -- (<object>, S, P'Address, D, B); 6994 -- Bnn := Communication_Bloc (D); 6995 6996 -- Param1 := P.Param1; 6997 -- ... 6998 -- ParamN := P.ParamN; 6999 7000 -- begin 7001 -- begin 7002 -- Abort_Undefer; 7003 -- <abortable-statements> 7004 -- at end 7005 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 7006 -- end; 7007 -- exception 7008 -- when Abort_Signal => Abort_Undefer; 7009 -- end; 7010 7011 -- if not U then 7012 -- <triggering-statements> 7013 -- end if; 7014 -- end; 7015 7016 -- else 7017 -- <dispatching-call>; 7018 -- <triggering-statements> 7019 -- end if; 7020 -- end if; 7021 -- end; 7022 7023 -- The job is to convert this to the asynchronous form 7024 7025 -- If the trigger is a delay statement, it will have been expanded into 7026 -- a call to one of the GNARL delay procedures. This routine will convert 7027 -- this into a protected entry call on a delay object and then continue 7028 -- processing as for a protected entry call trigger. This requires 7029 -- declaring a Delay_Block object and adding a pointer to this object to 7030 -- the parameter list of the delay procedure to form the parameter list of 7031 -- the entry call. This object is used by the runtime to queue the delay 7032 -- request. 7033 7034 -- For a description of the use of P and the assignments after the call, 7035 -- see Expand_N_Entry_Call_Statement. 7036 7037 procedure Expand_N_Asynchronous_Select (N : Node_Id) is 7038 Loc : constant Source_Ptr := Sloc (N); 7039 Abrt : constant Node_Id := Abortable_Part (N); 7040 Trig : constant Node_Id := Triggering_Alternative (N); 7041 7042 Abort_Block_Ent : Entity_Id; 7043 Abortable_Block : Node_Id; 7044 Actuals : List_Id; 7045 Astats : List_Id; 7046 Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A'); 7047 Blk_Typ : Entity_Id; 7048 Call : Node_Id; 7049 Call_Ent : Entity_Id; 7050 Cancel_Param : Entity_Id; 7051 Cleanup_Block : Node_Id; 7052 Cleanup_Block_Ent : Entity_Id; 7053 Cleanup_Stmts : List_Id; 7054 Conc_Typ_Stmts : List_Id; 7055 Concval : Node_Id; 7056 Dblock_Ent : Entity_Id; 7057 Decl : Node_Id; 7058 Decls : List_Id; 7059 Ecall : Node_Id; 7060 Ename : Node_Id; 7061 Enqueue_Call : Node_Id; 7062 Formals : List_Id; 7063 Hdle : List_Id; 7064 Index : Node_Id; 7065 Lim_Typ_Stmts : List_Id; 7066 N_Orig : Node_Id; 7067 Obj : Entity_Id; 7068 Param : Node_Id; 7069 Params : List_Id; 7070 Pdef : Entity_Id; 7071 ProtE_Stmts : List_Id; 7072 ProtP_Stmts : List_Id; 7073 Stmt : Node_Id; 7074 Stmts : List_Id; 7075 TaskE_Stmts : List_Id; 7076 Tstats : List_Id; 7077 7078 B : Entity_Id; -- Call status flag 7079 Bnn : Entity_Id; -- Communication block 7080 C : Entity_Id; -- Call kind 7081 K : Entity_Id; -- Tagged kind 7082 P : Entity_Id; -- Parameter block 7083 S : Entity_Id; -- Primitive operation slot 7084 T : Entity_Id; -- Additional status flag 7085 7086 procedure Rewrite_Abortable_Part; 7087 -- If the trigger is a dispatching call, the expansion inserts multiple 7088 -- copies of the abortable part. This is both inefficient, and may lead 7089 -- to duplicate definitions that the back-end will reject, when the 7090 -- abortable part includes loops. This procedure rewrites the abortable 7091 -- part into a call to a generated procedure. 7092 7093 ---------------------------- 7094 -- Rewrite_Abortable_Part -- 7095 ---------------------------- 7096 7097 procedure Rewrite_Abortable_Part is 7098 Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 7099 Decl : Node_Id; 7100 7101 begin 7102 Decl := 7103 Make_Subprogram_Body (Loc, 7104 Specification => 7105 Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc), 7106 Declarations => New_List, 7107 Handled_Statement_Sequence => 7108 Make_Handled_Sequence_Of_Statements (Loc, Astats)); 7109 Insert_Before (N, Decl); 7110 Analyze (Decl); 7111 7112 -- Rewrite abortable part into a call to this procedure 7113 7114 Astats := 7115 New_List ( 7116 Make_Procedure_Call_Statement (Loc, 7117 Name => New_Occurrence_Of (Proc, Loc))); 7118 end Rewrite_Abortable_Part; 7119 7120 -- Start of processing for Expand_N_Asynchronous_Select 7121 7122 begin 7123 -- Asynchronous select is not supported on restricted runtimes. Don't 7124 -- try to expand. 7125 7126 if Restricted_Profile then 7127 return; 7128 end if; 7129 7130 Process_Statements_For_Controlled_Objects (Trig); 7131 Process_Statements_For_Controlled_Objects (Abrt); 7132 7133 Ecall := Triggering_Statement (Trig); 7134 7135 Ensure_Statement_Present (Sloc (Ecall), Trig); 7136 7137 -- Retrieve Astats and Tstats now because the finalization machinery may 7138 -- wrap them in blocks. 7139 7140 Astats := Statements (Abrt); 7141 Tstats := Statements (Trig); 7142 7143 -- The arguments in the call may require dynamic allocation, and the 7144 -- call statement may have been transformed into a block. The block 7145 -- may contain additional declarations for internal entities, and the 7146 -- original call is found by sequential search. 7147 7148 if Nkind (Ecall) = N_Block_Statement then 7149 Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); 7150 while Nkind (Ecall) not in 7151 N_Procedure_Call_Statement | N_Entry_Call_Statement 7152 loop 7153 Next (Ecall); 7154 end loop; 7155 end if; 7156 7157 -- This is either a dispatching call or a delay statement used as a 7158 -- trigger which was expanded into a procedure call. 7159 7160 if Nkind (Ecall) = N_Procedure_Call_Statement then 7161 if Ada_Version >= Ada_2005 7162 and then 7163 (No (Original_Node (Ecall)) 7164 or else Nkind (Original_Node (Ecall)) not in N_Delay_Statement) 7165 then 7166 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals); 7167 7168 Rewrite_Abortable_Part; 7169 Decls := New_List; 7170 Stmts := New_List; 7171 7172 -- Call status flag processing, generate: 7173 -- B : Boolean := False; 7174 7175 B := Build_B (Loc, Decls); 7176 7177 -- Communication block processing, generate: 7178 -- Bnn : Communication_Block; 7179 7180 Bnn := Make_Temporary (Loc, 'B'); 7181 Append_To (Decls, 7182 Make_Object_Declaration (Loc, 7183 Defining_Identifier => Bnn, 7184 Object_Definition => 7185 New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); 7186 7187 -- Call kind processing, generate: 7188 -- C : Ada.Tags.Prim_Op_Kind; 7189 7190 C := Build_C (Loc, Decls); 7191 7192 -- Tagged kind processing, generate: 7193 -- K : Ada.Tags.Tagged_Kind := 7194 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7195 7196 -- Dummy communication block, generate: 7197 -- D : Dummy_Communication_Block; 7198 7199 Append_To (Decls, 7200 Make_Object_Declaration (Loc, 7201 Defining_Identifier => 7202 Make_Defining_Identifier (Loc, Name_uD), 7203 Object_Definition => 7204 New_Occurrence_Of 7205 (RTE (RE_Dummy_Communication_Block), Loc))); 7206 7207 K := Build_K (Loc, Decls, Obj); 7208 7209 -- Parameter block processing 7210 7211 Blk_Typ := Build_Parameter_Block 7212 (Loc, Actuals, Formals, Decls); 7213 P := Parameter_Block_Pack 7214 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 7215 7216 -- Dispatch table slot processing, generate: 7217 -- S : Integer; 7218 7219 S := Build_S (Loc, Decls); 7220 7221 -- Additional status flag processing, generate: 7222 -- Tnn : Boolean; 7223 7224 T := Make_Temporary (Loc, 'T'); 7225 Append_To (Decls, 7226 Make_Object_Declaration (Loc, 7227 Defining_Identifier => T, 7228 Object_Definition => 7229 New_Occurrence_Of (Standard_Boolean, Loc))); 7230 7231 ------------------------------ 7232 -- Protected entry handling -- 7233 ------------------------------ 7234 7235 -- Generate: 7236 -- Param1 := P.Param1; 7237 -- ... 7238 -- ParamN := P.ParamN; 7239 7240 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7241 7242 -- Generate: 7243 -- Bnn := Communication_Block (D); 7244 7245 Prepend_To (Cleanup_Stmts, 7246 Make_Assignment_Statement (Loc, 7247 Name => New_Occurrence_Of (Bnn, Loc), 7248 Expression => 7249 Make_Unchecked_Type_Conversion (Loc, 7250 Subtype_Mark => 7251 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7252 Expression => Make_Identifier (Loc, Name_uD)))); 7253 7254 -- Generate: 7255 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7256 7257 Prepend_To (Cleanup_Stmts, 7258 Make_Procedure_Call_Statement (Loc, 7259 Name => 7260 New_Occurrence_Of 7261 (Find_Prim_Op 7262 (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select), 7263 Loc), 7264 Parameter_Associations => 7265 New_List ( 7266 New_Copy_Tree (Obj), -- <object> 7267 New_Occurrence_Of (S, Loc), -- S 7268 Make_Attribute_Reference (Loc, -- P'Address 7269 Prefix => New_Occurrence_Of (P, Loc), 7270 Attribute_Name => Name_Address), 7271 Make_Identifier (Loc, Name_uD), -- D 7272 New_Occurrence_Of (B, Loc)))); -- B 7273 7274 -- Generate: 7275 -- if Enqueued (Bnn) then 7276 -- <abortable-statements> 7277 -- end if; 7278 7279 Append_To (Cleanup_Stmts, 7280 Make_Implicit_If_Statement (N, 7281 Condition => 7282 Make_Function_Call (Loc, 7283 Name => 7284 New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7285 Parameter_Associations => 7286 New_List (New_Occurrence_Of (Bnn, Loc))), 7287 7288 Then_Statements => 7289 New_Copy_List_Tree (Astats))); 7290 7291 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7292 -- will then generate a _clean for the communication block Bnn. 7293 7294 -- Generate: 7295 -- declare 7296 -- procedure _clean is 7297 -- begin 7298 -- if Enqueued (Bnn) then 7299 -- Cancel_Protected_Entry_Call (Bnn); 7300 -- end if; 7301 -- end _clean; 7302 -- begin 7303 -- Cleanup_Stmts 7304 -- at end 7305 -- _clean; 7306 -- end; 7307 7308 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7309 Cleanup_Block := 7310 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn); 7311 7312 -- Wrap the cleanup block in an exception handling block 7313 7314 -- Generate: 7315 -- begin 7316 -- Cleanup_Block 7317 -- exception 7318 -- when Abort_Signal => Abort_Undefer; 7319 -- end; 7320 7321 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7322 ProtE_Stmts := 7323 New_List ( 7324 Make_Implicit_Label_Declaration (Loc, 7325 Defining_Identifier => Abort_Block_Ent), 7326 7327 Build_Abort_Block 7328 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7329 7330 -- Generate: 7331 -- if not Cancelled (Bnn) then 7332 -- <triggering-statements> 7333 -- end if; 7334 7335 Append_To (ProtE_Stmts, 7336 Make_Implicit_If_Statement (N, 7337 Condition => 7338 Make_Op_Not (Loc, 7339 Right_Opnd => 7340 Make_Function_Call (Loc, 7341 Name => 7342 New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7343 Parameter_Associations => 7344 New_List (New_Occurrence_Of (Bnn, Loc)))), 7345 7346 Then_Statements => 7347 New_Copy_List_Tree (Tstats))); 7348 7349 ------------------------- 7350 -- Task entry handling -- 7351 ------------------------- 7352 7353 -- Generate: 7354 -- Param1 := P.Param1; 7355 -- ... 7356 -- ParamN := P.ParamN; 7357 7358 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7359 7360 -- Generate: 7361 -- Bnn := Communication_Block (D); 7362 7363 Append_To (TaskE_Stmts, 7364 Make_Assignment_Statement (Loc, 7365 Name => 7366 New_Occurrence_Of (Bnn, Loc), 7367 Expression => 7368 Make_Unchecked_Type_Conversion (Loc, 7369 Subtype_Mark => 7370 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7371 Expression => Make_Identifier (Loc, Name_uD)))); 7372 7373 -- Generate: 7374 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7375 7376 Prepend_To (TaskE_Stmts, 7377 Make_Procedure_Call_Statement (Loc, 7378 Name => 7379 New_Occurrence_Of ( 7380 Find_Prim_Op (Etype (Etype (Obj)), 7381 Name_uDisp_Asynchronous_Select), 7382 Loc), 7383 7384 Parameter_Associations => New_List ( 7385 New_Copy_Tree (Obj), -- <object> 7386 New_Occurrence_Of (S, Loc), -- S 7387 Make_Attribute_Reference (Loc, -- P'Address 7388 Prefix => New_Occurrence_Of (P, Loc), 7389 Attribute_Name => Name_Address), 7390 Make_Identifier (Loc, Name_uD), -- D 7391 New_Occurrence_Of (B, Loc)))); -- B 7392 7393 -- Generate: 7394 -- Abort_Defer; 7395 7396 Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 7397 7398 -- Generate: 7399 -- Abort_Undefer; 7400 -- <abortable-statements> 7401 7402 Cleanup_Stmts := New_Copy_List_Tree (Astats); 7403 7404 Prepend_To 7405 (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7406 7407 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7408 -- will generate a _clean for the additional status flag. 7409 7410 -- Generate: 7411 -- declare 7412 -- procedure _clean is 7413 -- begin 7414 -- Cancel_Task_Entry_Call (U); 7415 -- end _clean; 7416 -- begin 7417 -- Cleanup_Stmts 7418 -- at end 7419 -- _clean; 7420 -- end; 7421 7422 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7423 Cleanup_Block := 7424 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T); 7425 7426 -- Wrap the cleanup block in an exception handling block 7427 7428 -- Generate: 7429 -- begin 7430 -- Cleanup_Block 7431 -- exception 7432 -- when Abort_Signal => Abort_Undefer; 7433 -- end; 7434 7435 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7436 7437 Append_To (TaskE_Stmts, 7438 Make_Implicit_Label_Declaration (Loc, 7439 Defining_Identifier => Abort_Block_Ent)); 7440 7441 Append_To (TaskE_Stmts, 7442 Build_Abort_Block 7443 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7444 7445 -- Generate: 7446 -- if not T then 7447 -- <triggering-statements> 7448 -- end if; 7449 7450 Append_To (TaskE_Stmts, 7451 Make_Implicit_If_Statement (N, 7452 Condition => 7453 Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)), 7454 7455 Then_Statements => 7456 New_Copy_List_Tree (Tstats))); 7457 7458 ---------------------------------- 7459 -- Protected procedure handling -- 7460 ---------------------------------- 7461 7462 -- Generate: 7463 -- <dispatching-call>; 7464 -- <triggering-statements> 7465 7466 ProtP_Stmts := New_Copy_List_Tree (Tstats); 7467 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall)); 7468 7469 -- Generate: 7470 -- S := Ada.Tags.Get_Offset_Index 7471 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 7472 7473 Conc_Typ_Stmts := 7474 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 7475 7476 -- Generate: 7477 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 7478 7479 Append_To (Conc_Typ_Stmts, 7480 Make_Procedure_Call_Statement (Loc, 7481 Name => 7482 New_Occurrence_Of 7483 (Find_Prim_Op (Etype (Etype (Obj)), 7484 Name_uDisp_Get_Prim_Op_Kind), 7485 Loc), 7486 Parameter_Associations => 7487 New_List ( 7488 New_Copy_Tree (Obj), 7489 New_Occurrence_Of (S, Loc), 7490 New_Occurrence_Of (C, Loc)))); 7491 7492 -- Generate: 7493 -- if C = POK_Procedure_Entry then 7494 -- ProtE_Stmts 7495 -- elsif C = POK_Task_Entry then 7496 -- TaskE_Stmts 7497 -- else 7498 -- ProtP_Stmts 7499 -- end if; 7500 7501 Append_To (Conc_Typ_Stmts, 7502 Make_Implicit_If_Statement (N, 7503 Condition => 7504 Make_Op_Eq (Loc, 7505 Left_Opnd => 7506 New_Occurrence_Of (C, Loc), 7507 Right_Opnd => 7508 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 7509 7510 Then_Statements => 7511 ProtE_Stmts, 7512 7513 Elsif_Parts => 7514 New_List ( 7515 Make_Elsif_Part (Loc, 7516 Condition => 7517 Make_Op_Eq (Loc, 7518 Left_Opnd => 7519 New_Occurrence_Of (C, Loc), 7520 Right_Opnd => 7521 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)), 7522 7523 Then_Statements => 7524 TaskE_Stmts)), 7525 7526 Else_Statements => 7527 ProtP_Stmts)); 7528 7529 -- Generate: 7530 -- <dispatching-call>; 7531 -- <triggering-statements> 7532 7533 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats); 7534 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall)); 7535 7536 -- Generate: 7537 -- if K = Ada.Tags.TK_Limited_Tagged 7538 -- or else K = Ada.Tags.TK_Tagged 7539 -- then 7540 -- Lim_Typ_Stmts 7541 -- else 7542 -- Conc_Typ_Stmts 7543 -- end if; 7544 7545 Append_To (Stmts, 7546 Make_Implicit_If_Statement (N, 7547 Condition => Build_Dispatching_Tag_Check (K, N), 7548 Then_Statements => Lim_Typ_Stmts, 7549 Else_Statements => Conc_Typ_Stmts)); 7550 7551 Rewrite (N, 7552 Make_Block_Statement (Loc, 7553 Declarations => 7554 Decls, 7555 Handled_Statement_Sequence => 7556 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7557 7558 Analyze (N); 7559 return; 7560 7561 -- Delay triggering statement processing 7562 7563 else 7564 -- Add a Delay_Block object to the parameter list of the delay 7565 -- procedure to form the parameter list of the Wait entry call. 7566 7567 Dblock_Ent := Make_Temporary (Loc, 'D'); 7568 7569 Pdef := Entity (Name (Ecall)); 7570 7571 if Is_RTE (Pdef, RO_CA_Delay_For) then 7572 Enqueue_Call := 7573 New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc); 7574 7575 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then 7576 Enqueue_Call := 7577 New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc); 7578 7579 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); 7580 Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc); 7581 end if; 7582 7583 Append_To (Parameter_Associations (Ecall), 7584 Make_Attribute_Reference (Loc, 7585 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7586 Attribute_Name => Name_Unchecked_Access)); 7587 7588 -- Create the inner block to protect the abortable part 7589 7590 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7591 7592 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7593 7594 Abortable_Block := 7595 Make_Block_Statement (Loc, 7596 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7597 Handled_Statement_Sequence => 7598 Make_Handled_Sequence_Of_Statements (Loc, 7599 Statements => Astats), 7600 Has_Created_Identifier => True, 7601 Is_Asynchronous_Call_Block => True); 7602 7603 -- Append call to if Enqueue (When, DB'Unchecked_Access) then 7604 7605 Rewrite (Ecall, 7606 Make_Implicit_If_Statement (N, 7607 Condition => 7608 Make_Function_Call (Loc, 7609 Name => Enqueue_Call, 7610 Parameter_Associations => Parameter_Associations (Ecall)), 7611 Then_Statements => 7612 New_List (Make_Block_Statement (Loc, 7613 Handled_Statement_Sequence => 7614 Make_Handled_Sequence_Of_Statements (Loc, 7615 Statements => New_List ( 7616 Make_Implicit_Label_Declaration (Loc, 7617 Defining_Identifier => Blk_Ent, 7618 Label_Construct => Abortable_Block), 7619 Abortable_Block), 7620 Exception_Handlers => Hdle))))); 7621 7622 Stmts := New_List (Ecall); 7623 7624 -- Construct statement sequence for new block 7625 7626 Append_To (Stmts, 7627 Make_Implicit_If_Statement (N, 7628 Condition => 7629 Make_Function_Call (Loc, 7630 Name => New_Occurrence_Of ( 7631 RTE (RE_Timed_Out), Loc), 7632 Parameter_Associations => New_List ( 7633 Make_Attribute_Reference (Loc, 7634 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7635 Attribute_Name => Name_Unchecked_Access))), 7636 Then_Statements => Tstats)); 7637 7638 -- The result is the new block 7639 7640 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent); 7641 7642 Rewrite (N, 7643 Make_Block_Statement (Loc, 7644 Declarations => New_List ( 7645 Make_Object_Declaration (Loc, 7646 Defining_Identifier => Dblock_Ent, 7647 Aliased_Present => True, 7648 Object_Definition => 7649 New_Occurrence_Of (RTE (RE_Delay_Block), Loc))), 7650 7651 Handled_Statement_Sequence => 7652 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7653 7654 Analyze (N); 7655 return; 7656 end if; 7657 7658 else 7659 N_Orig := N; 7660 end if; 7661 7662 Extract_Entry (Ecall, Concval, Ename, Index); 7663 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index); 7664 7665 Stmts := Statements (Handled_Statement_Sequence (Ecall)); 7666 Decls := Declarations (Ecall); 7667 7668 if Is_Protected_Type (Etype (Concval)) then 7669 7670 -- Get the declarations of the block expanded from the entry call 7671 7672 Decl := First (Decls); 7673 while Present (Decl) 7674 and then (Nkind (Decl) /= N_Object_Declaration 7675 or else not Is_RTE (Etype (Object_Definition (Decl)), 7676 RE_Communication_Block)) 7677 loop 7678 Next (Decl); 7679 end loop; 7680 7681 pragma Assert (Present (Decl)); 7682 Cancel_Param := Defining_Identifier (Decl); 7683 7684 -- Change the mode of the Protected_Entry_Call call 7685 7686 -- Protected_Entry_Call ( 7687 -- Object => po._object'Access, 7688 -- E => <entry index>; 7689 -- Uninterpreted_Data => P'Address; 7690 -- Mode => Asynchronous_Call; 7691 -- Block => Bnn); 7692 7693 -- Skip assignments to temporaries created for in-out parameters 7694 7695 -- This makes unwarranted assumptions about the shape of the expanded 7696 -- tree for the call, and should be cleaned up ??? 7697 7698 Stmt := First (Stmts); 7699 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7700 Next (Stmt); 7701 end loop; 7702 7703 Call := Stmt; 7704 7705 Param := First (Parameter_Associations (Call)); 7706 while Present (Param) 7707 and then not Is_RTE (Etype (Param), RE_Call_Modes) 7708 loop 7709 Next (Param); 7710 end loop; 7711 7712 pragma Assert (Present (Param)); 7713 Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7714 Analyze (Param); 7715 7716 -- Append an if statement to execute the abortable part 7717 7718 -- Generate: 7719 -- if Enqueued (Bnn) then 7720 7721 Append_To (Stmts, 7722 Make_Implicit_If_Statement (N, 7723 Condition => 7724 Make_Function_Call (Loc, 7725 Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7726 Parameter_Associations => New_List ( 7727 New_Occurrence_Of (Cancel_Param, Loc))), 7728 Then_Statements => Astats)); 7729 7730 Abortable_Block := 7731 Make_Block_Statement (Loc, 7732 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7733 Handled_Statement_Sequence => 7734 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts), 7735 Has_Created_Identifier => True, 7736 Is_Asynchronous_Call_Block => True); 7737 7738 Stmts := New_List ( 7739 Make_Block_Statement (Loc, 7740 Handled_Statement_Sequence => 7741 Make_Handled_Sequence_Of_Statements (Loc, 7742 Statements => New_List ( 7743 Make_Implicit_Label_Declaration (Loc, 7744 Defining_Identifier => Blk_Ent, 7745 Label_Construct => Abortable_Block), 7746 Abortable_Block), 7747 7748 -- exception 7749 7750 Exception_Handlers => New_List ( 7751 Make_Implicit_Exception_Handler (Loc, 7752 7753 -- when Abort_Signal => 7754 -- null; 7755 7756 Exception_Choices => 7757 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)), 7758 Statements => New_List (Make_Null_Statement (Loc)))))), 7759 7760 -- if not Cancelled (Bnn) then 7761 -- triggered statements 7762 -- end if; 7763 7764 Make_Implicit_If_Statement (N, 7765 Condition => Make_Op_Not (Loc, 7766 Right_Opnd => 7767 Make_Function_Call (Loc, 7768 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7769 Parameter_Associations => New_List ( 7770 New_Occurrence_Of (Cancel_Param, Loc)))), 7771 Then_Statements => Tstats)); 7772 7773 -- Asynchronous task entry call 7774 7775 else 7776 if No (Decls) then 7777 Decls := New_List; 7778 end if; 7779 7780 B := Make_Defining_Identifier (Loc, Name_uB); 7781 7782 -- Insert declaration of B in declarations of existing block 7783 7784 Prepend_To (Decls, 7785 Make_Object_Declaration (Loc, 7786 Defining_Identifier => B, 7787 Object_Definition => 7788 New_Occurrence_Of (Standard_Boolean, Loc))); 7789 7790 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC); 7791 7792 -- Insert the declaration of C in the declarations of the existing 7793 -- block. The variable is initialized to something (True or False, 7794 -- does not matter) to prevent CodePeer from complaining about a 7795 -- possible read of an uninitialized variable. 7796 7797 Prepend_To (Decls, 7798 Make_Object_Declaration (Loc, 7799 Defining_Identifier => Cancel_Param, 7800 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 7801 Expression => New_Occurrence_Of (Standard_False, Loc), 7802 Has_Init_Expression => True)); 7803 7804 -- Remove and save the call to Call_Simple 7805 7806 Stmt := First (Stmts); 7807 7808 -- Skip assignments to temporaries created for in-out parameters. 7809 -- This makes unwarranted assumptions about the shape of the expanded 7810 -- tree for the call, and should be cleaned up ??? 7811 7812 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7813 Next (Stmt); 7814 end loop; 7815 7816 Call := Stmt; 7817 7818 -- Create the inner block to protect the abortable part 7819 7820 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7821 7822 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7823 7824 Abortable_Block := 7825 Make_Block_Statement (Loc, 7826 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7827 Handled_Statement_Sequence => 7828 Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats), 7829 Has_Created_Identifier => True, 7830 Is_Asynchronous_Call_Block => True); 7831 7832 Insert_After (Call, 7833 Make_Block_Statement (Loc, 7834 Handled_Statement_Sequence => 7835 Make_Handled_Sequence_Of_Statements (Loc, 7836 Statements => New_List ( 7837 Make_Implicit_Label_Declaration (Loc, 7838 Defining_Identifier => Blk_Ent, 7839 Label_Construct => Abortable_Block), 7840 Abortable_Block), 7841 Exception_Handlers => Hdle))); 7842 7843 -- Create new call statement 7844 7845 Params := Parameter_Associations (Call); 7846 7847 Append_To (Params, 7848 New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7849 Append_To (Params, New_Occurrence_Of (B, Loc)); 7850 7851 Rewrite (Call, 7852 Make_Procedure_Call_Statement (Loc, 7853 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 7854 Parameter_Associations => Params)); 7855 7856 -- Construct statement sequence for new block 7857 7858 Append_To (Stmts, 7859 Make_Implicit_If_Statement (N, 7860 Condition => 7861 Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)), 7862 Then_Statements => Tstats)); 7863 7864 -- Protected the call against abort 7865 7866 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 7867 end if; 7868 7869 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param); 7870 7871 -- The result is the new block 7872 7873 Rewrite (N_Orig, 7874 Make_Block_Statement (Loc, 7875 Declarations => Decls, 7876 Handled_Statement_Sequence => 7877 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7878 7879 Analyze (N_Orig); 7880 end Expand_N_Asynchronous_Select; 7881 7882 ------------------------------------- 7883 -- Expand_N_Conditional_Entry_Call -- 7884 ------------------------------------- 7885 7886 -- The conditional task entry call is converted to a call to 7887 -- Task_Entry_Call: 7888 7889 -- declare 7890 -- B : Boolean; 7891 -- P : parms := (parm, parm, parm); 7892 7893 -- begin 7894 -- Task_Entry_Call 7895 -- (<acceptor-task>, -- Acceptor 7896 -- <entry-index>, -- E 7897 -- P'Address, -- Uninterpreted_Data 7898 -- Conditional_Call, -- Mode 7899 -- B); -- Rendezvous_Successful 7900 -- parm := P.param; 7901 -- parm := P.param; 7902 -- ... 7903 -- if B then 7904 -- normal-statements 7905 -- else 7906 -- else-statements 7907 -- end if; 7908 -- end; 7909 7910 -- For a description of the use of P and the assignments after the call, 7911 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the 7912 -- conditional entry call has already been expanded (by the Expand_N_Entry 7913 -- _Call_Statement procedure) as follows: 7914 7915 -- declare 7916 -- P : parms := (parm, parm, parm); 7917 -- begin 7918 -- ... info for in-out parameters 7919 -- Call_Simple (acceptor-task, entry-index, P'Address); 7920 -- parm := P.param; 7921 -- parm := P.param; 7922 -- ... 7923 -- end; 7924 7925 -- so the task at hand is to convert the latter expansion into the former 7926 7927 -- The conditional protected entry call is converted to a call to 7928 -- Protected_Entry_Call: 7929 7930 -- declare 7931 -- P : parms := (parm, parm, parm); 7932 -- Bnn : Communications_Block; 7933 7934 -- begin 7935 -- Protected_Entry_Call 7936 -- (po._object'Access, -- Object 7937 -- <entry index>, -- E 7938 -- P'Address, -- Uninterpreted_Data 7939 -- Conditional_Call, -- Mode 7940 -- Bnn); -- Block 7941 -- parm := P.param; 7942 -- parm := P.param; 7943 -- ... 7944 -- if Cancelled (Bnn) then 7945 -- else-statements 7946 -- else 7947 -- normal-statements 7948 -- end if; 7949 -- end; 7950 7951 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted 7952 -- into: 7953 7954 -- declare 7955 -- B : Boolean := False; 7956 -- C : Ada.Tags.Prim_Op_Kind; 7957 -- K : Ada.Tags.Tagged_Kind := 7958 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7959 -- P : Parameters := (Param1 .. ParamN); 7960 -- S : Integer; 7961 7962 -- begin 7963 -- if K = Ada.Tags.TK_Limited_Tagged 7964 -- or else K = Ada.Tags.TK_Tagged 7965 -- then 7966 -- <dispatching-call>; 7967 -- <triggering-statements> 7968 7969 -- else 7970 -- S := 7971 -- Ada.Tags.Get_Offset_Index 7972 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 7973 7974 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 7975 7976 -- if C = POK_Protected_Entry 7977 -- or else C = POK_Task_Entry 7978 -- then 7979 -- Param1 := P.Param1; 7980 -- ... 7981 -- ParamN := P.ParamN; 7982 -- end if; 7983 7984 -- if B then 7985 -- if C = POK_Procedure 7986 -- or else C = POK_Protected_Procedure 7987 -- or else C = POK_Task_Procedure 7988 -- then 7989 -- <dispatching-call>; 7990 -- end if; 7991 7992 -- <triggering-statements> 7993 -- else 7994 -- <else-statements> 7995 -- end if; 7996 -- end if; 7997 -- end; 7998 7999 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is 8000 Loc : constant Source_Ptr := Sloc (N); 8001 Alt : constant Node_Id := Entry_Call_Alternative (N); 8002 Blk : Node_Id := Entry_Call_Statement (Alt); 8003 8004 Actuals : List_Id; 8005 Blk_Typ : Entity_Id; 8006 Call : Node_Id; 8007 Call_Ent : Entity_Id; 8008 Conc_Typ_Stmts : List_Id; 8009 Decl : Node_Id; 8010 Decls : List_Id; 8011 Formals : List_Id; 8012 Lim_Typ_Stmts : List_Id; 8013 N_Stats : List_Id; 8014 Obj : Entity_Id; 8015 Param : Node_Id; 8016 Params : List_Id; 8017 Stmt : Node_Id; 8018 Stmts : List_Id; 8019 Transient_Blk : Node_Id; 8020 Unpack : List_Id; 8021 8022 B : Entity_Id; -- Call status flag 8023 C : Entity_Id; -- Call kind 8024 K : Entity_Id; -- Tagged kind 8025 P : Entity_Id; -- Parameter block 8026 S : Entity_Id; -- Primitive operation slot 8027 8028 begin 8029 Process_Statements_For_Controlled_Objects (N); 8030 8031 if Ada_Version >= Ada_2005 8032 and then Nkind (Blk) = N_Procedure_Call_Statement 8033 then 8034 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals); 8035 8036 Decls := New_List; 8037 Stmts := New_List; 8038 8039 -- Call status flag processing, generate: 8040 -- B : Boolean := False; 8041 8042 B := Build_B (Loc, Decls); 8043 8044 -- Call kind processing, generate: 8045 -- C : Ada.Tags.Prim_Op_Kind; 8046 8047 C := Build_C (Loc, Decls); 8048 8049 -- Tagged kind processing, generate: 8050 -- K : Ada.Tags.Tagged_Kind := 8051 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 8052 8053 K := Build_K (Loc, Decls, Obj); 8054 8055 -- Parameter block processing 8056 8057 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 8058 P := Parameter_Block_Pack 8059 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 8060 8061 -- Dispatch table slot processing, generate: 8062 -- S : Integer; 8063 8064 S := Build_S (Loc, Decls); 8065 8066 -- Generate: 8067 -- S := Ada.Tags.Get_Offset_Index 8068 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 8069 8070 Conc_Typ_Stmts := 8071 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 8072 8073 -- Generate: 8074 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 8075 8076 Append_To (Conc_Typ_Stmts, 8077 Make_Procedure_Call_Statement (Loc, 8078 Name => 8079 New_Occurrence_Of ( 8080 Find_Prim_Op (Etype (Etype (Obj)), 8081 Name_uDisp_Conditional_Select), 8082 Loc), 8083 Parameter_Associations => 8084 New_List ( 8085 New_Copy_Tree (Obj), -- <object> 8086 New_Occurrence_Of (S, Loc), -- S 8087 Make_Attribute_Reference (Loc, -- P'Address 8088 Prefix => New_Occurrence_Of (P, Loc), 8089 Attribute_Name => Name_Address), 8090 New_Occurrence_Of (C, Loc), -- C 8091 New_Occurrence_Of (B, Loc)))); -- B 8092 8093 -- Generate: 8094 -- if C = POK_Protected_Entry 8095 -- or else C = POK_Task_Entry 8096 -- then 8097 -- Param1 := P.Param1; 8098 -- ... 8099 -- ParamN := P.ParamN; 8100 -- end if; 8101 8102 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 8103 8104 -- Generate the if statement only when the packed parameters need 8105 -- explicit assignments to their corresponding actuals. 8106 8107 if Present (Unpack) then 8108 Append_To (Conc_Typ_Stmts, 8109 Make_Implicit_If_Statement (N, 8110 Condition => 8111 Make_Or_Else (Loc, 8112 Left_Opnd => 8113 Make_Op_Eq (Loc, 8114 Left_Opnd => 8115 New_Occurrence_Of (C, Loc), 8116 Right_Opnd => 8117 New_Occurrence_Of (RTE ( 8118 RE_POK_Protected_Entry), Loc)), 8119 8120 Right_Opnd => 8121 Make_Op_Eq (Loc, 8122 Left_Opnd => 8123 New_Occurrence_Of (C, Loc), 8124 Right_Opnd => 8125 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 8126 8127 Then_Statements => Unpack)); 8128 end if; 8129 8130 -- Generate: 8131 -- if B then 8132 -- if C = POK_Procedure 8133 -- or else C = POK_Protected_Procedure 8134 -- or else C = POK_Task_Procedure 8135 -- then 8136 -- <dispatching-call> 8137 -- end if; 8138 -- <normal-statements> 8139 -- else 8140 -- <else-statements> 8141 -- end if; 8142 8143 N_Stats := New_Copy_Separate_List (Statements (Alt)); 8144 8145 Prepend_To (N_Stats, 8146 Make_Implicit_If_Statement (N, 8147 Condition => 8148 Make_Or_Else (Loc, 8149 Left_Opnd => 8150 Make_Op_Eq (Loc, 8151 Left_Opnd => 8152 New_Occurrence_Of (C, Loc), 8153 Right_Opnd => 8154 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 8155 8156 Right_Opnd => 8157 Make_Or_Else (Loc, 8158 Left_Opnd => 8159 Make_Op_Eq (Loc, 8160 Left_Opnd => 8161 New_Occurrence_Of (C, Loc), 8162 Right_Opnd => 8163 New_Occurrence_Of (RTE ( 8164 RE_POK_Protected_Procedure), Loc)), 8165 8166 Right_Opnd => 8167 Make_Op_Eq (Loc, 8168 Left_Opnd => 8169 New_Occurrence_Of (C, Loc), 8170 Right_Opnd => 8171 New_Occurrence_Of (RTE ( 8172 RE_POK_Task_Procedure), Loc)))), 8173 8174 Then_Statements => 8175 New_List (Blk))); 8176 8177 Append_To (Conc_Typ_Stmts, 8178 Make_Implicit_If_Statement (N, 8179 Condition => New_Occurrence_Of (B, Loc), 8180 Then_Statements => N_Stats, 8181 Else_Statements => Else_Statements (N))); 8182 8183 -- Generate: 8184 -- <dispatching-call>; 8185 -- <triggering-statements> 8186 8187 Lim_Typ_Stmts := New_Copy_Separate_List (Statements (Alt)); 8188 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); 8189 8190 -- Generate: 8191 -- if K = Ada.Tags.TK_Limited_Tagged 8192 -- or else K = Ada.Tags.TK_Tagged 8193 -- then 8194 -- Lim_Typ_Stmts 8195 -- else 8196 -- Conc_Typ_Stmts 8197 -- end if; 8198 8199 Append_To (Stmts, 8200 Make_Implicit_If_Statement (N, 8201 Condition => Build_Dispatching_Tag_Check (K, N), 8202 Then_Statements => Lim_Typ_Stmts, 8203 Else_Statements => Conc_Typ_Stmts)); 8204 8205 Rewrite (N, 8206 Make_Block_Statement (Loc, 8207 Declarations => 8208 Decls, 8209 Handled_Statement_Sequence => 8210 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8211 8212 -- As described above, the entry alternative is transformed into a 8213 -- block that contains the gnulli call, and possibly assignment 8214 -- statements for in-out parameters. The gnulli call may itself be 8215 -- rewritten into a transient block if some unconstrained parameters 8216 -- require it. We need to retrieve the call to complete its parameter 8217 -- list. 8218 8219 else 8220 Transient_Blk := 8221 First_Real_Statement (Handled_Statement_Sequence (Blk)); 8222 8223 if Present (Transient_Blk) 8224 and then Nkind (Transient_Blk) = N_Block_Statement 8225 then 8226 Blk := Transient_Blk; 8227 end if; 8228 8229 Stmts := Statements (Handled_Statement_Sequence (Blk)); 8230 Stmt := First (Stmts); 8231 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 8232 Next (Stmt); 8233 end loop; 8234 8235 Call := Stmt; 8236 Params := Parameter_Associations (Call); 8237 8238 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then 8239 8240 -- Substitute Conditional_Entry_Call for Simple_Call parameter 8241 8242 Param := First (Params); 8243 while Present (Param) 8244 and then not Is_RTE (Etype (Param), RE_Call_Modes) 8245 loop 8246 Next (Param); 8247 end loop; 8248 8249 pragma Assert (Present (Param)); 8250 Rewrite (Param, 8251 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8252 8253 Analyze (Param); 8254 8255 -- Find the Communication_Block parameter for the call to the 8256 -- Cancelled function. 8257 8258 Decl := First (Declarations (Blk)); 8259 while Present (Decl) 8260 and then not Is_RTE (Etype (Object_Definition (Decl)), 8261 RE_Communication_Block) 8262 loop 8263 Next (Decl); 8264 end loop; 8265 8266 -- Add an if statement to execute the else part if the call 8267 -- does not succeed (as indicated by the Cancelled predicate). 8268 8269 Append_To (Stmts, 8270 Make_Implicit_If_Statement (N, 8271 Condition => Make_Function_Call (Loc, 8272 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 8273 Parameter_Associations => New_List ( 8274 New_Occurrence_Of (Defining_Identifier (Decl), Loc))), 8275 Then_Statements => Else_Statements (N), 8276 Else_Statements => Statements (Alt))); 8277 8278 else 8279 B := Make_Defining_Identifier (Loc, Name_uB); 8280 8281 -- Insert declaration of B in declarations of existing block 8282 8283 if No (Declarations (Blk)) then 8284 Set_Declarations (Blk, New_List); 8285 end if; 8286 8287 Prepend_To (Declarations (Blk), 8288 Make_Object_Declaration (Loc, 8289 Defining_Identifier => B, 8290 Object_Definition => 8291 New_Occurrence_Of (Standard_Boolean, Loc))); 8292 8293 -- Create new call statement 8294 8295 Append_To (Params, 8296 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8297 Append_To (Params, New_Occurrence_Of (B, Loc)); 8298 8299 Rewrite (Call, 8300 Make_Procedure_Call_Statement (Loc, 8301 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 8302 Parameter_Associations => Params)); 8303 8304 -- Construct statement sequence for new block 8305 8306 Append_To (Stmts, 8307 Make_Implicit_If_Statement (N, 8308 Condition => New_Occurrence_Of (B, Loc), 8309 Then_Statements => Statements (Alt), 8310 Else_Statements => Else_Statements (N))); 8311 end if; 8312 8313 -- The result is the new block 8314 8315 Rewrite (N, 8316 Make_Block_Statement (Loc, 8317 Declarations => Declarations (Blk), 8318 Handled_Statement_Sequence => 8319 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8320 end if; 8321 8322 Analyze (N); 8323 8324 Reset_Scopes_To (N, Entity (Identifier (N))); 8325 end Expand_N_Conditional_Entry_Call; 8326 8327 --------------------------------------- 8328 -- Expand_N_Delay_Relative_Statement -- 8329 --------------------------------------- 8330 8331 -- Delay statement is implemented as a procedure call to Delay_For 8332 -- defined in Ada.Calendar.Delays in order to reduce the overhead of 8333 -- simple delays imposed by the use of Protected Objects. 8334 8335 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is 8336 Loc : constant Source_Ptr := Sloc (N); 8337 Proc : Entity_Id; 8338 8339 begin 8340 -- Try to use Ada.Calendar.Delays.Delay_For if available. 8341 8342 if RTE_Available (RO_CA_Delay_For) then 8343 Proc := RTE (RO_CA_Delay_For); 8344 8345 -- Otherwise, use System.Relative_Delays.Delay_For and emit an error 8346 -- message if not available. This is the implementation used on 8347 -- restricted platforms when Ada.Calendar is not available. 8348 8349 else 8350 Proc := RTE (RO_RD_Delay_For); 8351 end if; 8352 8353 Rewrite (N, 8354 Make_Procedure_Call_Statement (Loc, 8355 Name => New_Occurrence_Of (Proc, Loc), 8356 Parameter_Associations => New_List (Expression (N)))); 8357 Analyze (N); 8358 end Expand_N_Delay_Relative_Statement; 8359 8360 ------------------------------------ 8361 -- Expand_N_Delay_Until_Statement -- 8362 ------------------------------------ 8363 8364 -- Delay Until statement is implemented as a procedure call to 8365 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays. 8366 8367 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is 8368 Loc : constant Source_Ptr := Sloc (N); 8369 Typ : Entity_Id; 8370 8371 begin 8372 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then 8373 Typ := RTE (RO_CA_Delay_Until); 8374 else 8375 Typ := RTE (RO_RT_Delay_Until); 8376 end if; 8377 8378 Rewrite (N, 8379 Make_Procedure_Call_Statement (Loc, 8380 Name => New_Occurrence_Of (Typ, Loc), 8381 Parameter_Associations => New_List (Expression (N)))); 8382 8383 Analyze (N); 8384 end Expand_N_Delay_Until_Statement; 8385 8386 ------------------------- 8387 -- Expand_N_Entry_Body -- 8388 ------------------------- 8389 8390 procedure Expand_N_Entry_Body (N : Node_Id) is 8391 begin 8392 -- Associate discriminals with the next protected operation body to be 8393 -- expanded. 8394 8395 if Present (Next_Protected_Operation (N)) then 8396 Set_Discriminals (Parent (Current_Scope)); 8397 end if; 8398 end Expand_N_Entry_Body; 8399 8400 ----------------------------------- 8401 -- Expand_N_Entry_Call_Statement -- 8402 ----------------------------------- 8403 8404 -- An entry call is expanded into GNARLI calls to implement a simple entry 8405 -- call (see Build_Simple_Entry_Call). 8406 8407 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is 8408 Concval : Node_Id; 8409 Ename : Node_Id; 8410 Index : Node_Id; 8411 8412 begin 8413 if No_Run_Time_Mode then 8414 Error_Msg_CRT ("entry call", N); 8415 return; 8416 end if; 8417 8418 -- If this entry call is part of an asynchronous select, don't expand it 8419 -- here; it will be expanded with the select statement. Don't expand 8420 -- timed entry calls either, as they are translated into asynchronous 8421 -- entry calls. 8422 8423 -- ??? This whole approach is questionable; it may be better to go back 8424 -- to allowing the expansion to take place and then attempting to fix it 8425 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out 8426 -- whether the expanded call is on a task or protected entry. 8427 8428 if (Nkind (Parent (N)) /= N_Triggering_Alternative 8429 or else N /= Triggering_Statement (Parent (N))) 8430 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative 8431 or else N /= Entry_Call_Statement (Parent (N)) 8432 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call) 8433 then 8434 Extract_Entry (N, Concval, Ename, Index); 8435 Build_Simple_Entry_Call (N, Concval, Ename, Index); 8436 end if; 8437 end Expand_N_Entry_Call_Statement; 8438 8439 -------------------------------- 8440 -- Expand_N_Entry_Declaration -- 8441 -------------------------------- 8442 8443 -- If there are parameters, then first, each of the formals is marked by 8444 -- setting Is_Entry_Formal. Next a record type is built which is used to 8445 -- hold the parameter values. The name of this record type is entryP where 8446 -- entry is the name of the entry, with an additional corresponding access 8447 -- type called entryPA. The record type has matching components for each 8448 -- formal (the component names are the same as the formal names). For 8449 -- elementary types, the component type matches the formal type. For 8450 -- composite types, an access type is declared (with the name formalA) 8451 -- which designates the formal type, and the type of the component is this 8452 -- access type. Finally the Entry_Component of each formal is set to 8453 -- reference the corresponding record component. 8454 8455 procedure Expand_N_Entry_Declaration (N : Node_Id) is 8456 Loc : constant Source_Ptr := Sloc (N); 8457 Entry_Ent : constant Entity_Id := Defining_Identifier (N); 8458 Components : List_Id; 8459 Formal : Node_Id; 8460 Ftype : Entity_Id; 8461 Last_Decl : Node_Id; 8462 Component : Entity_Id; 8463 Ctype : Entity_Id; 8464 Decl : Node_Id; 8465 Rec_Ent : Entity_Id; 8466 Acc_Ent : Entity_Id; 8467 8468 begin 8469 Formal := First_Formal (Entry_Ent); 8470 Last_Decl := N; 8471 8472 -- Most processing is done only if parameters are present 8473 8474 if Present (Formal) then 8475 Components := New_List; 8476 8477 -- Loop through formals 8478 8479 while Present (Formal) loop 8480 Set_Is_Entry_Formal (Formal); 8481 Component := 8482 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); 8483 Set_Entry_Component (Formal, Component); 8484 Set_Entry_Formal (Component, Formal); 8485 Ftype := Etype (Formal); 8486 8487 -- Declare new access type and then append 8488 8489 Ctype := Make_Temporary (Loc, 'A'); 8490 Set_Is_Param_Block_Component_Type (Ctype); 8491 8492 Decl := 8493 Make_Full_Type_Declaration (Loc, 8494 Defining_Identifier => Ctype, 8495 Type_Definition => 8496 Make_Access_To_Object_Definition (Loc, 8497 All_Present => True, 8498 Constant_Present => Ekind (Formal) = E_In_Parameter, 8499 Subtype_Indication => New_Occurrence_Of (Ftype, Loc))); 8500 8501 Insert_After (Last_Decl, Decl); 8502 Last_Decl := Decl; 8503 8504 Append_To (Components, 8505 Make_Component_Declaration (Loc, 8506 Defining_Identifier => Component, 8507 Component_Definition => 8508 Make_Component_Definition (Loc, 8509 Aliased_Present => False, 8510 Subtype_Indication => New_Occurrence_Of (Ctype, Loc)))); 8511 8512 Next_Formal_With_Extras (Formal); 8513 end loop; 8514 8515 -- Create the Entry_Parameter_Record declaration 8516 8517 Rec_Ent := Make_Temporary (Loc, 'P'); 8518 8519 Decl := 8520 Make_Full_Type_Declaration (Loc, 8521 Defining_Identifier => Rec_Ent, 8522 Type_Definition => 8523 Make_Record_Definition (Loc, 8524 Component_List => 8525 Make_Component_List (Loc, 8526 Component_Items => Components))); 8527 8528 Insert_After (Last_Decl, Decl); 8529 Last_Decl := Decl; 8530 8531 -- Construct and link in the corresponding access type 8532 8533 Acc_Ent := Make_Temporary (Loc, 'A'); 8534 8535 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); 8536 8537 Decl := 8538 Make_Full_Type_Declaration (Loc, 8539 Defining_Identifier => Acc_Ent, 8540 Type_Definition => 8541 Make_Access_To_Object_Definition (Loc, 8542 All_Present => True, 8543 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc))); 8544 8545 Insert_After (Last_Decl, Decl); 8546 end if; 8547 end Expand_N_Entry_Declaration; 8548 8549 ----------------------------- 8550 -- Expand_N_Protected_Body -- 8551 ----------------------------- 8552 8553 -- Protected bodies are expanded to the completion of the subprograms 8554 -- created for the corresponding protected type. These are a protected and 8555 -- unprotected version of each protected subprogram in the object, a 8556 -- function to calculate each entry barrier, and a procedure to execute the 8557 -- sequence of statements of each protected entry body. For example, for 8558 -- protected type ptype: 8559 8560 -- function entB 8561 -- (O : System.Address; 8562 -- E : Protected_Entry_Index) 8563 -- return Boolean 8564 -- is 8565 -- <discriminant renamings> 8566 -- <private object renamings> 8567 -- begin 8568 -- return <barrier expression>; 8569 -- end entB; 8570 8571 -- procedure pprocN (_object : in out poV;...) is 8572 -- <discriminant renamings> 8573 -- <private object renamings> 8574 -- begin 8575 -- <sequence of statements> 8576 -- end pprocN; 8577 8578 -- procedure pprocP (_object : in out poV;...) is 8579 -- procedure _clean is 8580 -- Pn : Boolean; 8581 -- begin 8582 -- ptypeS (_object, Pn); 8583 -- Unlock (_object._object'Access); 8584 -- Abort_Undefer.all; 8585 -- end _clean; 8586 8587 -- begin 8588 -- Abort_Defer.all; 8589 -- Lock (_object._object'Access); 8590 -- pprocN (_object;...); 8591 -- at end 8592 -- _clean; 8593 -- end pproc; 8594 8595 -- function pfuncN (_object : poV;...) return Return_Type is 8596 -- <discriminant renamings> 8597 -- <private object renamings> 8598 -- begin 8599 -- <sequence of statements> 8600 -- end pfuncN; 8601 8602 -- function pfuncP (_object : poV) return Return_Type is 8603 -- procedure _clean is 8604 -- begin 8605 -- Unlock (_object._object'Access); 8606 -- Abort_Undefer.all; 8607 -- end _clean; 8608 8609 -- begin 8610 -- Abort_Defer.all; 8611 -- Lock (_object._object'Access); 8612 -- return pfuncN (_object); 8613 8614 -- at end 8615 -- _clean; 8616 -- end pfunc; 8617 8618 -- procedure entE 8619 -- (O : System.Address; 8620 -- P : System.Address; 8621 -- E : Protected_Entry_Index) 8622 -- is 8623 -- <discriminant renamings> 8624 -- <private object renamings> 8625 -- type poVP is access poV; 8626 -- _Object : ptVP := ptVP!(O); 8627 8628 -- begin 8629 -- begin 8630 -- <statement sequence> 8631 -- Complete_Entry_Body (_Object._Object); 8632 -- exception 8633 -- when all others => 8634 -- Exceptional_Complete_Entry_Body ( 8635 -- _Object._Object, Get_GNAT_Exception); 8636 -- end; 8637 -- end entE; 8638 8639 -- The type poV is the record created for the protected type to hold 8640 -- the state of the protected object. 8641 8642 procedure Expand_N_Protected_Body (N : Node_Id) is 8643 Loc : constant Source_Ptr := Sloc (N); 8644 Pid : constant Entity_Id := Corresponding_Spec (N); 8645 8646 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid); 8647 -- This flag indicates whether the lock free implementation is active 8648 8649 Current_Node : Node_Id; 8650 Disp_Op_Body : Node_Id; 8651 New_Op_Body : Node_Id; 8652 Op_Body : Node_Id; 8653 Op_Decl : Node_Id; 8654 Op_Id : Entity_Id; 8655 8656 function Build_Dispatching_Subprogram_Body 8657 (N : Node_Id; 8658 Pid : Node_Id; 8659 Prot_Bod : Node_Id) return Node_Id; 8660 -- Build a dispatching version of the protected subprogram body. The 8661 -- newly generated subprogram contains a call to the original protected 8662 -- body. The following code is generated: 8663 -- 8664 -- function <protected-function-name> (Param1 .. ParamN) return 8665 -- <return-type> is 8666 -- begin 8667 -- return <protected-function-name>P (Param1 .. ParamN); 8668 -- end <protected-function-name>; 8669 -- 8670 -- or 8671 -- 8672 -- procedure <protected-procedure-name> (Param1 .. ParamN) is 8673 -- begin 8674 -- <protected-procedure-name>P (Param1 .. ParamN); 8675 -- end <protected-procedure-name> 8676 8677 --------------------------------------- 8678 -- Build_Dispatching_Subprogram_Body -- 8679 --------------------------------------- 8680 8681 function Build_Dispatching_Subprogram_Body 8682 (N : Node_Id; 8683 Pid : Node_Id; 8684 Prot_Bod : Node_Id) return Node_Id 8685 is 8686 Loc : constant Source_Ptr := Sloc (N); 8687 Actuals : List_Id; 8688 Formal : Node_Id; 8689 Spec : Node_Id; 8690 Stmts : List_Id; 8691 8692 begin 8693 -- Generate a specification without a letter suffix in order to 8694 -- override an interface function or procedure. 8695 8696 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode); 8697 8698 -- The formal parameters become the actuals of the protected function 8699 -- or procedure call. 8700 8701 Actuals := New_List; 8702 Formal := First (Parameter_Specifications (Spec)); 8703 while Present (Formal) loop 8704 Append_To (Actuals, 8705 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 8706 Next (Formal); 8707 end loop; 8708 8709 if Nkind (Spec) = N_Procedure_Specification then 8710 Stmts := 8711 New_List ( 8712 Make_Procedure_Call_Statement (Loc, 8713 Name => 8714 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8715 Parameter_Associations => Actuals)); 8716 8717 else 8718 pragma Assert (Nkind (Spec) = N_Function_Specification); 8719 8720 Stmts := 8721 New_List ( 8722 Make_Simple_Return_Statement (Loc, 8723 Expression => 8724 Make_Function_Call (Loc, 8725 Name => 8726 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8727 Parameter_Associations => Actuals))); 8728 end if; 8729 8730 return 8731 Make_Subprogram_Body (Loc, 8732 Declarations => Empty_List, 8733 Specification => Spec, 8734 Handled_Statement_Sequence => 8735 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 8736 end Build_Dispatching_Subprogram_Body; 8737 8738 -- Start of processing for Expand_N_Protected_Body 8739 8740 begin 8741 if No_Run_Time_Mode then 8742 Error_Msg_CRT ("protected body", N); 8743 return; 8744 end if; 8745 8746 -- This is the proper body corresponding to a stub. The declarations 8747 -- must be inserted at the point of the stub, which in turn is in the 8748 -- declarative part of the parent unit. 8749 8750 if Nkind (Parent (N)) = N_Subunit then 8751 Current_Node := Corresponding_Stub (Parent (N)); 8752 else 8753 Current_Node := N; 8754 end if; 8755 8756 Op_Body := First (Declarations (N)); 8757 8758 -- The protected body is replaced with the bodies of its protected 8759 -- operations, and the declarations for internal objects that may 8760 -- have been created for entry family bounds. 8761 8762 Rewrite (N, Make_Null_Statement (Sloc (N))); 8763 Analyze (N); 8764 8765 while Present (Op_Body) loop 8766 case Nkind (Op_Body) is 8767 when N_Subprogram_Declaration => 8768 null; 8769 8770 when N_Subprogram_Body => 8771 8772 -- Do not create bodies for eliminated operations 8773 8774 if not Is_Eliminated (Defining_Entity (Op_Body)) 8775 and then not Is_Eliminated (Corresponding_Spec (Op_Body)) 8776 then 8777 if Lock_Free_Active then 8778 New_Op_Body := 8779 Build_Lock_Free_Unprotected_Subprogram_Body 8780 (Op_Body, Pid); 8781 else 8782 New_Op_Body := 8783 Build_Unprotected_Subprogram_Body (Op_Body, Pid); 8784 end if; 8785 8786 Insert_After (Current_Node, New_Op_Body); 8787 Current_Node := New_Op_Body; 8788 Analyze (New_Op_Body); 8789 8790 -- When the original protected body has nested subprograms, 8791 -- the new body also has them, so set the flag accordingly 8792 -- and reset the scopes of the top-level nested subprograms 8793 -- and other declaration entities so that they now refer to 8794 -- the new body's entity. (It would preferable to do this 8795 -- within Build_Protected_Sub_Specification, which is called 8796 -- from Build_Unprotected_Subprogram_Body, but the needed 8797 -- subprogram entity isn't available via Corresponding_Spec 8798 -- until after the above Analyze call.) 8799 8800 if Has_Nested_Subprogram (Corresponding_Spec (Op_Body)) then 8801 Set_Has_Nested_Subprogram 8802 (Corresponding_Spec (New_Op_Body)); 8803 8804 Reset_Scopes_To 8805 (New_Op_Body, Corresponding_Spec (New_Op_Body)); 8806 end if; 8807 8808 -- Build the corresponding protected operation. This is 8809 -- needed only if this is a public or private operation of 8810 -- the type. 8811 8812 -- Why do we need to test for Corresponding_Spec being 8813 -- present here when it's assumed to be set further above 8814 -- in the Is_Eliminated test??? 8815 8816 if Present (Corresponding_Spec (Op_Body)) then 8817 Op_Decl := 8818 Unit_Declaration_Node (Corresponding_Spec (Op_Body)); 8819 8820 if Nkind (Parent (Op_Decl)) = N_Protected_Definition then 8821 if Lock_Free_Active then 8822 New_Op_Body := 8823 Build_Lock_Free_Protected_Subprogram_Body 8824 (Op_Body, Pid, Specification (New_Op_Body)); 8825 else 8826 New_Op_Body := 8827 Build_Protected_Subprogram_Body ( 8828 Op_Body, Pid, Specification (New_Op_Body)); 8829 end if; 8830 8831 Insert_After (Current_Node, New_Op_Body); 8832 Analyze (New_Op_Body); 8833 Current_Node := New_Op_Body; 8834 8835 -- Generate an overriding primitive operation body for 8836 -- this subprogram if the protected type implements 8837 -- an interface. 8838 8839 if Ada_Version >= Ada_2005 8840 and then Present (Interfaces ( 8841 Corresponding_Record_Type (Pid))) 8842 then 8843 Disp_Op_Body := 8844 Build_Dispatching_Subprogram_Body ( 8845 Op_Body, Pid, New_Op_Body); 8846 8847 Insert_After (Current_Node, Disp_Op_Body); 8848 Analyze (Disp_Op_Body); 8849 8850 Current_Node := Disp_Op_Body; 8851 end if; 8852 end if; 8853 end if; 8854 end if; 8855 8856 when N_Entry_Body => 8857 Op_Id := Defining_Identifier (Op_Body); 8858 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); 8859 8860 Insert_After (Current_Node, New_Op_Body); 8861 Current_Node := New_Op_Body; 8862 Analyze (New_Op_Body); 8863 8864 when N_Implicit_Label_Declaration => 8865 null; 8866 8867 when N_Call_Marker 8868 | N_Itype_Reference 8869 => 8870 New_Op_Body := New_Copy (Op_Body); 8871 Insert_After (Current_Node, New_Op_Body); 8872 Current_Node := New_Op_Body; 8873 8874 when N_Freeze_Entity => 8875 New_Op_Body := New_Copy (Op_Body); 8876 8877 if Present (Entity (Op_Body)) 8878 and then Freeze_Node (Entity (Op_Body)) = Op_Body 8879 then 8880 Set_Freeze_Node (Entity (Op_Body), New_Op_Body); 8881 end if; 8882 8883 Insert_After (Current_Node, New_Op_Body); 8884 Current_Node := New_Op_Body; 8885 Analyze (New_Op_Body); 8886 8887 when N_Pragma => 8888 New_Op_Body := New_Copy (Op_Body); 8889 Insert_After (Current_Node, New_Op_Body); 8890 Current_Node := New_Op_Body; 8891 Analyze (New_Op_Body); 8892 8893 when N_Object_Declaration => 8894 pragma Assert (not Comes_From_Source (Op_Body)); 8895 New_Op_Body := New_Copy (Op_Body); 8896 Insert_After (Current_Node, New_Op_Body); 8897 Current_Node := New_Op_Body; 8898 Analyze (New_Op_Body); 8899 8900 when others => 8901 raise Program_Error; 8902 end case; 8903 8904 Next (Op_Body); 8905 end loop; 8906 8907 -- Finally, create the body of the function that maps an entry index 8908 -- into the corresponding body index, except when there is no entry, or 8909 -- in a Ravenscar-like profile. 8910 8911 if Corresponding_Runtime_Package (Pid) = 8912 System_Tasking_Protected_Objects_Entries 8913 then 8914 New_Op_Body := Build_Find_Body_Index (Pid); 8915 Insert_After (Current_Node, New_Op_Body); 8916 Current_Node := New_Op_Body; 8917 Analyze (New_Op_Body); 8918 end if; 8919 8920 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the 8921 -- protected body. At this point all wrapper specs have been created, 8922 -- frozen and included in the dispatch table for the protected type. 8923 8924 if Ada_Version >= Ada_2005 then 8925 Build_Wrapper_Bodies (Loc, Pid, Current_Node); 8926 end if; 8927 end Expand_N_Protected_Body; 8928 8929 ----------------------------------------- 8930 -- Expand_N_Protected_Type_Declaration -- 8931 ----------------------------------------- 8932 8933 -- First we create a corresponding record type declaration used to 8934 -- represent values of this protected type. 8935 -- The general form of this type declaration is 8936 8937 -- type poV (discriminants) is record 8938 -- _Object : aliased <kind>Protection 8939 -- [(<entry count> [, <handler count>])]; 8940 -- [entry_family : array (bounds) of Void;] 8941 -- <private data fields> 8942 -- end record; 8943 8944 -- The discriminants are present only if the corresponding protected type 8945 -- has discriminants, and they exactly mirror the protected type 8946 -- discriminants. The private data fields similarly mirror the private 8947 -- declarations of the protected type. 8948 8949 -- The Object field is always present. It contains RTS specific data used 8950 -- to control the protected object. It is declared as Aliased so that it 8951 -- can be passed as a pointer to the RTS. This allows the protected record 8952 -- to be referenced within RTS data structures. An appropriate Protection 8953 -- type and discriminant are generated. 8954 8955 -- The Service field is present for protected objects with entries. It 8956 -- contains sufficient information to allow the entry service procedure for 8957 -- this object to be called when the object is not known till runtime. 8958 8959 -- One entry_family component is present for each entry family in the 8960 -- task definition (see Expand_N_Task_Type_Declaration). 8961 8962 -- When a protected object is declared, an instance of the protected type 8963 -- value record is created. The elaboration of this declaration creates the 8964 -- correct bounds for the entry families, and also evaluates the priority 8965 -- expression if needed. The initialization routine for the protected type 8966 -- itself then calls Initialize_Protection with appropriate parameters to 8967 -- initialize the value of the Task_Id field. Install_Handlers may be also 8968 -- called if a pragma Attach_Handler applies. 8969 8970 -- Note: this record is passed to the subprograms created by the expansion 8971 -- of protected subprograms and entries. It is an in parameter to protected 8972 -- functions and an in out parameter to procedures and entry bodies. The 8973 -- Entity_Id for this created record type is placed in the 8974 -- Corresponding_Record_Type field of the associated protected type entity. 8975 8976 -- Next we create a procedure specifications for protected subprograms and 8977 -- entry bodies. For each protected subprograms two subprograms are 8978 -- created, an unprotected and a protected version. The unprotected version 8979 -- is called from within other operations of the same protected object. 8980 8981 -- We also build the call to register the procedure if a pragma 8982 -- Interrupt_Handler applies. 8983 8984 -- A single subprogram is created to service all entry bodies; it has an 8985 -- additional boolean out parameter indicating that the previous entry call 8986 -- made by the current task was serviced immediately, i.e. not by proxy. 8987 -- The O parameter contains a pointer to a record object of the type 8988 -- described above. An untyped interface is used here to allow this 8989 -- procedure to be called in places where the type of the object to be 8990 -- serviced is not known. This must be done, for example, when a call that 8991 -- may have been requeued is cancelled; the corresponding object must be 8992 -- serviced, but which object that is not known till runtime. 8993 8994 -- procedure ptypeS 8995 -- (O : System.Address; P : out Boolean); 8996 -- procedure pprocN (_object : in out poV); 8997 -- procedure pproc (_object : in out poV); 8998 -- function pfuncN (_object : poV); 8999 -- function pfunc (_object : poV); 9000 -- ... 9001 9002 -- Note that this must come after the record type declaration, since 9003 -- the specs refer to this type. 9004 9005 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is 9006 Discr_Map : constant Elist_Id := New_Elmt_List; 9007 Loc : constant Source_Ptr := Sloc (N); 9008 Prot_Typ : constant Entity_Id := Defining_Identifier (N); 9009 9010 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ); 9011 -- This flag indicates whether the lock free implementation is active 9012 9013 Pdef : constant Node_Id := Protected_Definition (N); 9014 -- This contains two lists; one for visible and one for private decls 9015 9016 Current_Node : Node_Id := N; 9017 E_Count : Int; 9018 Entries_Aggr : Node_Id; 9019 Rec_Decl : Node_Id; 9020 Rec_Id : Entity_Id; 9021 9022 procedure Check_Inlining (Subp : Entity_Id); 9023 -- If the original operation has a pragma Inline, propagate the flag 9024 -- to the internal body, for possible inlining later on. The source 9025 -- operation is invisible to the back-end and is never actually called. 9026 9027 procedure Expand_Entry_Declaration (Decl : Node_Id); 9028 -- Create the entry barrier and the procedure body for entry declaration 9029 -- Decl. All generated subprograms are added to Entry_Bodies_Array. 9030 9031 function Static_Component_Size (Comp : Entity_Id) return Boolean; 9032 -- When compiling under the Ravenscar profile, private components must 9033 -- have a static size, or else a protected object will require heap 9034 -- allocation, violating the corresponding restriction. It is preferable 9035 -- to make this check here, because it provides a better error message 9036 -- than the back-end, which refers to the object as a whole. 9037 9038 procedure Register_Handler; 9039 -- For a protected operation that is an interrupt handler, add the 9040 -- freeze action that will register it as such. 9041 9042 procedure Replace_Access_Definition (Comp : Node_Id); 9043 -- If a private component of the type is an access to itself, this 9044 -- is not a reference to the current instance, but an access type out 9045 -- of which one might construct a list. If such a component exists, we 9046 -- create an incomplete type for the equivalent record type, and 9047 -- a named access type for it, that replaces the access definition 9048 -- of the original component. This is similar to what is done for 9049 -- records in Check_Anonymous_Access_Components, but simpler, because 9050 -- the corresponding record type has no previous declaration. 9051 -- This needs to be done only once, even if there are several such 9052 -- access components. The following entity stores the constructed 9053 -- access type. 9054 9055 Acc_T : Entity_Id := Empty; 9056 9057 -------------------- 9058 -- Check_Inlining -- 9059 -------------------- 9060 9061 procedure Check_Inlining (Subp : Entity_Id) is 9062 begin 9063 if Is_Inlined (Subp) then 9064 Set_Is_Inlined (Protected_Body_Subprogram (Subp)); 9065 Set_Is_Inlined (Subp, False); 9066 end if; 9067 9068 if Has_Pragma_No_Inline (Subp) then 9069 Set_Has_Pragma_No_Inline (Protected_Body_Subprogram (Subp)); 9070 end if; 9071 end Check_Inlining; 9072 9073 --------------------------- 9074 -- Static_Component_Size -- 9075 --------------------------- 9076 9077 function Static_Component_Size (Comp : Entity_Id) return Boolean is 9078 Typ : constant Entity_Id := Etype (Comp); 9079 C : Entity_Id; 9080 9081 begin 9082 if Is_Scalar_Type (Typ) then 9083 return True; 9084 9085 elsif Is_Array_Type (Typ) then 9086 return Compile_Time_Known_Bounds (Typ); 9087 9088 elsif Is_Record_Type (Typ) then 9089 C := First_Component (Typ); 9090 while Present (C) loop 9091 if not Static_Component_Size (C) then 9092 return False; 9093 end if; 9094 9095 Next_Component (C); 9096 end loop; 9097 9098 return True; 9099 9100 -- Any other type will be checked by the back-end 9101 9102 else 9103 return True; 9104 end if; 9105 end Static_Component_Size; 9106 9107 ------------------------------ 9108 -- Expand_Entry_Declaration -- 9109 ------------------------------ 9110 9111 procedure Expand_Entry_Declaration (Decl : Node_Id) is 9112 Ent_Id : constant Entity_Id := Defining_Entity (Decl); 9113 Bar_Id : Entity_Id; 9114 Bod_Id : Entity_Id; 9115 Subp : Node_Id; 9116 9117 begin 9118 E_Count := E_Count + 1; 9119 9120 -- Create the protected body subprogram 9121 9122 Bod_Id := 9123 Make_Defining_Identifier (Loc, 9124 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E')); 9125 Set_Protected_Body_Subprogram (Ent_Id, Bod_Id); 9126 9127 Subp := 9128 Make_Subprogram_Declaration (Loc, 9129 Specification => 9130 Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id)); 9131 9132 Insert_After (Current_Node, Subp); 9133 Current_Node := Subp; 9134 9135 Analyze (Subp); 9136 9137 -- Build a wrapper procedure to handle contract cases, preconditions, 9138 -- and postconditions. 9139 9140 Build_Contract_Wrapper (Ent_Id, N); 9141 9142 -- Create the barrier function 9143 9144 Bar_Id := 9145 Make_Defining_Identifier (Loc, 9146 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B')); 9147 Set_Barrier_Function (Ent_Id, Bar_Id); 9148 9149 Subp := 9150 Make_Subprogram_Declaration (Loc, 9151 Specification => 9152 Build_Barrier_Function_Specification (Loc, Bar_Id)); 9153 Set_Is_Entry_Barrier_Function (Subp); 9154 9155 Insert_After (Current_Node, Subp); 9156 Current_Node := Subp; 9157 9158 Analyze (Subp); 9159 9160 Set_Protected_Body_Subprogram (Bar_Id, Bar_Id); 9161 Set_Scope (Bar_Id, Scope (Ent_Id)); 9162 9163 -- Collect pointers to the protected subprogram and the barrier 9164 -- of the current entry, for insertion into Entry_Bodies_Array. 9165 9166 Append_To (Expressions (Entries_Aggr), 9167 Make_Aggregate (Loc, 9168 Expressions => New_List ( 9169 Make_Attribute_Reference (Loc, 9170 Prefix => New_Occurrence_Of (Bar_Id, Loc), 9171 Attribute_Name => Name_Unrestricted_Access), 9172 Make_Attribute_Reference (Loc, 9173 Prefix => New_Occurrence_Of (Bod_Id, Loc), 9174 Attribute_Name => Name_Unrestricted_Access)))); 9175 end Expand_Entry_Declaration; 9176 9177 ---------------------- 9178 -- Register_Handler -- 9179 ---------------------- 9180 9181 procedure Register_Handler is 9182 9183 -- All semantic checks already done in Sem_Prag 9184 9185 Prot_Proc : constant Entity_Id := 9186 Defining_Unit_Name (Specification (Current_Node)); 9187 9188 Proc_Address : constant Node_Id := 9189 Make_Attribute_Reference (Loc, 9190 Prefix => 9191 New_Occurrence_Of (Prot_Proc, Loc), 9192 Attribute_Name => Name_Address); 9193 9194 RTS_Call : constant Entity_Id := 9195 Make_Procedure_Call_Statement (Loc, 9196 Name => 9197 New_Occurrence_Of 9198 (RTE (RE_Register_Interrupt_Handler), Loc), 9199 Parameter_Associations => New_List (Proc_Address)); 9200 begin 9201 Append_Freeze_Action (Prot_Proc, RTS_Call); 9202 end Register_Handler; 9203 9204 ------------------------------- 9205 -- Replace_Access_Definition -- 9206 ------------------------------- 9207 9208 procedure Replace_Access_Definition (Comp : Node_Id) is 9209 Loc : constant Source_Ptr := Sloc (Comp); 9210 Inc_T : Node_Id; 9211 Inc_D : Node_Id; 9212 Acc_Def : Node_Id; 9213 Acc_D : Node_Id; 9214 9215 begin 9216 if No (Acc_T) then 9217 Inc_T := Make_Defining_Identifier (Loc, Chars (Rec_Id)); 9218 Inc_D := Make_Incomplete_Type_Declaration (Loc, Inc_T); 9219 Acc_T := Make_Temporary (Loc, 'S'); 9220 Acc_Def := 9221 Make_Access_To_Object_Definition (Loc, 9222 Subtype_Indication => New_Occurrence_Of (Inc_T, Loc)); 9223 Acc_D := 9224 Make_Full_Type_Declaration (Loc, 9225 Defining_Identifier => Acc_T, 9226 Type_Definition => Acc_Def); 9227 9228 Insert_Before (Rec_Decl, Inc_D); 9229 Analyze (Inc_D); 9230 9231 Insert_Before (Rec_Decl, Acc_D); 9232 Analyze (Acc_D); 9233 end if; 9234 9235 Set_Access_Definition (Comp, Empty); 9236 Set_Subtype_Indication (Comp, New_Occurrence_Of (Acc_T, Loc)); 9237 end Replace_Access_Definition; 9238 9239 -- Local variables 9240 9241 Body_Arr : Node_Id; 9242 Body_Id : Entity_Id; 9243 Cdecls : List_Id; 9244 Comp : Node_Id; 9245 Expr : Node_Id; 9246 New_Priv : Node_Id; 9247 Obj_Def : Node_Id; 9248 Object_Comp : Node_Id; 9249 Priv : Node_Id; 9250 Sub : Node_Id; 9251 9252 -- Start of processing for Expand_N_Protected_Type_Declaration 9253 9254 begin 9255 if Present (Corresponding_Record_Type (Prot_Typ)) then 9256 return; 9257 else 9258 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); 9259 Rec_Id := Defining_Identifier (Rec_Decl); 9260 end if; 9261 9262 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); 9263 9264 Qualify_Entity_Names (N); 9265 9266 -- If the type has discriminants, their occurrences in the declaration 9267 -- have been replaced by the corresponding discriminals. For components 9268 -- that are constrained by discriminants, their homologues in the 9269 -- corresponding record type must refer to the discriminants of that 9270 -- record, so we must apply a new renaming to subtypes_indications: 9271 9272 -- protected discriminant => discriminal => record discriminant 9273 9274 -- This replacement is not applied to default expressions, for which 9275 -- the discriminal is correct. 9276 9277 if Has_Discriminants (Prot_Typ) then 9278 declare 9279 Disc : Entity_Id; 9280 Decl : Node_Id; 9281 9282 begin 9283 Disc := First_Discriminant (Prot_Typ); 9284 Decl := First (Discriminant_Specifications (Rec_Decl)); 9285 while Present (Disc) loop 9286 Append_Elmt (Discriminal (Disc), Discr_Map); 9287 Append_Elmt (Defining_Identifier (Decl), Discr_Map); 9288 Next_Discriminant (Disc); 9289 Next (Decl); 9290 end loop; 9291 end; 9292 end if; 9293 9294 -- Fill in the component declarations 9295 9296 -- Add components for entry families. For each entry family, create an 9297 -- anonymous type declaration with the same size, and analyze the type. 9298 9299 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); 9300 9301 pragma Assert (Present (Pdef)); 9302 9303 Insert_After (Current_Node, Rec_Decl); 9304 Current_Node := Rec_Decl; 9305 9306 -- Add private field components 9307 9308 if Present (Private_Declarations (Pdef)) then 9309 Priv := First (Private_Declarations (Pdef)); 9310 while Present (Priv) loop 9311 if Nkind (Priv) = N_Component_Declaration then 9312 if not Static_Component_Size (Defining_Identifier (Priv)) then 9313 9314 -- When compiling for a restricted profile, the private 9315 -- components must have a static size. If not, this is an 9316 -- error for a single protected declaration, and rates a 9317 -- warning on a protected type declaration. 9318 9319 if not Comes_From_Source (Prot_Typ) then 9320 9321 -- It's ok to be checking this restriction at expansion 9322 -- time, because this is only for the restricted profile, 9323 -- which is not subject to strict RM conformance, so it 9324 -- is OK to miss this check in -gnatc mode. 9325 9326 Check_Restriction (No_Implicit_Heap_Allocations, Priv); 9327 Check_Restriction 9328 (No_Implicit_Protected_Object_Allocations, Priv); 9329 9330 elsif Restriction_Active (No_Implicit_Heap_Allocations) then 9331 if not Discriminated_Size (Defining_Identifier (Priv)) 9332 then 9333 -- Any object of the type will be non-static 9334 9335 Error_Msg_N ("component has non-static size??", Priv); 9336 Error_Msg_NE 9337 ("\creation of protected object of type& will " 9338 & "violate restriction " 9339 & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ); 9340 else 9341 -- Object will be non-static if discriminants are 9342 9343 Error_Msg_NE 9344 ("creation of protected object of type& with " 9345 & "non-static discriminants will violate " 9346 & "restriction No_Implicit_Heap_Allocations??", 9347 Priv, Prot_Typ); 9348 end if; 9349 9350 -- Likewise for No_Implicit_Protected_Object_Allocations 9351 9352 elsif Restriction_Active 9353 (No_Implicit_Protected_Object_Allocations) 9354 then 9355 if not Discriminated_Size (Defining_Identifier (Priv)) 9356 then 9357 -- Any object of the type will be non-static 9358 9359 Error_Msg_N ("component has non-static size??", Priv); 9360 Error_Msg_NE 9361 ("\creation of protected object of type& will " 9362 & "violate restriction " 9363 & "No_Implicit_Protected_Object_Allocations??", 9364 Priv, Prot_Typ); 9365 else 9366 -- Object will be non-static if discriminants are 9367 9368 Error_Msg_NE 9369 ("creation of protected object of type& with " 9370 & "non-static discriminants will violate " 9371 & "restriction " 9372 & "No_Implicit_Protected_Object_Allocations??", 9373 Priv, Prot_Typ); 9374 end if; 9375 end if; 9376 end if; 9377 9378 -- The component definition consists of a subtype indication, 9379 -- or (in Ada 2005) an access definition. Make a copy of the 9380 -- proper definition. 9381 9382 declare 9383 Old_Comp : constant Node_Id := Component_Definition (Priv); 9384 Oent : constant Entity_Id := Defining_Identifier (Priv); 9385 Nent : constant Entity_Id := 9386 Make_Defining_Identifier (Sloc (Oent), 9387 Chars => Chars (Oent)); 9388 New_Comp : Node_Id; 9389 9390 begin 9391 if Present (Subtype_Indication (Old_Comp)) then 9392 New_Comp := 9393 Make_Component_Definition (Sloc (Oent), 9394 Aliased_Present => False, 9395 Subtype_Indication => 9396 New_Copy_Tree 9397 (Subtype_Indication (Old_Comp), Discr_Map)); 9398 else 9399 New_Comp := 9400 Make_Component_Definition (Sloc (Oent), 9401 Aliased_Present => False, 9402 Access_Definition => 9403 New_Copy_Tree 9404 (Access_Definition (Old_Comp), Discr_Map)); 9405 9406 -- A self-reference in the private part becomes a 9407 -- self-reference to the corresponding record. 9408 9409 if Entity (Subtype_Mark (Access_Definition (New_Comp))) 9410 = Prot_Typ 9411 then 9412 Replace_Access_Definition (New_Comp); 9413 end if; 9414 end if; 9415 9416 New_Priv := 9417 Make_Component_Declaration (Loc, 9418 Defining_Identifier => Nent, 9419 Component_Definition => New_Comp, 9420 Expression => Expression (Priv)); 9421 9422 Set_Has_Per_Object_Constraint (Nent, 9423 Has_Per_Object_Constraint (Oent)); 9424 9425 Append_To (Cdecls, New_Priv); 9426 end; 9427 9428 elsif Nkind (Priv) = N_Subprogram_Declaration then 9429 9430 -- Make the unprotected version of the subprogram available 9431 -- for expansion of intra object calls. There is need for 9432 -- a protected version only if the subprogram is an interrupt 9433 -- handler, otherwise this operation can only be called from 9434 -- within the body. 9435 9436 Sub := 9437 Make_Subprogram_Declaration (Loc, 9438 Specification => 9439 Build_Protected_Sub_Specification 9440 (Priv, Prot_Typ, Unprotected_Mode)); 9441 9442 Insert_After (Current_Node, Sub); 9443 Analyze (Sub); 9444 9445 Set_Protected_Body_Subprogram 9446 (Defining_Unit_Name (Specification (Priv)), 9447 Defining_Unit_Name (Specification (Sub))); 9448 Check_Inlining (Defining_Unit_Name (Specification (Priv))); 9449 Current_Node := Sub; 9450 9451 Sub := 9452 Make_Subprogram_Declaration (Loc, 9453 Specification => 9454 Build_Protected_Sub_Specification 9455 (Priv, Prot_Typ, Protected_Mode)); 9456 9457 Insert_After (Current_Node, Sub); 9458 Analyze (Sub); 9459 Current_Node := Sub; 9460 9461 if Is_Interrupt_Handler 9462 (Defining_Unit_Name (Specification (Priv))) 9463 then 9464 if not Restricted_Profile then 9465 Register_Handler; 9466 end if; 9467 end if; 9468 end if; 9469 9470 Next (Priv); 9471 end loop; 9472 end if; 9473 9474 -- Except for the lock-free implementation, append the _Object field 9475 -- with the right type to the component list. We need to compute the 9476 -- number of entries, and in some cases the number of Attach_Handler 9477 -- pragmas. 9478 9479 if not Lock_Free_Active then 9480 declare 9481 Entry_Count_Expr : constant Node_Id := 9482 Build_Entry_Count_Expression 9483 (Prot_Typ, Cdecls, Loc); 9484 Num_Attach_Handler : Nat := 0; 9485 Protection_Subtype : Node_Id; 9486 Ritem : Node_Id; 9487 9488 begin 9489 if Has_Attach_Handler (Prot_Typ) then 9490 Ritem := First_Rep_Item (Prot_Typ); 9491 while Present (Ritem) loop 9492 if Nkind (Ritem) = N_Pragma 9493 and then Pragma_Name (Ritem) = Name_Attach_Handler 9494 then 9495 Num_Attach_Handler := Num_Attach_Handler + 1; 9496 end if; 9497 9498 Next_Rep_Item (Ritem); 9499 end loop; 9500 end if; 9501 9502 -- Determine the proper protection type. There are two special 9503 -- cases: 1) when the protected type has dynamic interrupt 9504 -- handlers, and 2) when it has static handlers and we use a 9505 -- restricted profile. 9506 9507 if Has_Attach_Handler (Prot_Typ) 9508 and then not Restricted_Profile 9509 then 9510 Protection_Subtype := 9511 Make_Subtype_Indication (Loc, 9512 Subtype_Mark => 9513 New_Occurrence_Of 9514 (RTE (RE_Static_Interrupt_Protection), Loc), 9515 Constraint => 9516 Make_Index_Or_Discriminant_Constraint (Loc, 9517 Constraints => New_List ( 9518 Entry_Count_Expr, 9519 Make_Integer_Literal (Loc, Num_Attach_Handler)))); 9520 9521 elsif Has_Interrupt_Handler (Prot_Typ) 9522 and then not Restriction_Active (No_Dynamic_Attachment) 9523 then 9524 Protection_Subtype := 9525 Make_Subtype_Indication (Loc, 9526 Subtype_Mark => 9527 New_Occurrence_Of 9528 (RTE (RE_Dynamic_Interrupt_Protection), Loc), 9529 Constraint => 9530 Make_Index_Or_Discriminant_Constraint (Loc, 9531 Constraints => New_List (Entry_Count_Expr))); 9532 9533 else 9534 case Corresponding_Runtime_Package (Prot_Typ) is 9535 when System_Tasking_Protected_Objects_Entries => 9536 Protection_Subtype := 9537 Make_Subtype_Indication (Loc, 9538 Subtype_Mark => 9539 New_Occurrence_Of 9540 (RTE (RE_Protection_Entries), Loc), 9541 Constraint => 9542 Make_Index_Or_Discriminant_Constraint (Loc, 9543 Constraints => New_List (Entry_Count_Expr))); 9544 9545 when System_Tasking_Protected_Objects_Single_Entry => 9546 Protection_Subtype := 9547 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc); 9548 9549 when System_Tasking_Protected_Objects => 9550 Protection_Subtype := 9551 New_Occurrence_Of (RTE (RE_Protection), Loc); 9552 9553 when others => 9554 raise Program_Error; 9555 end case; 9556 end if; 9557 9558 Object_Comp := 9559 Make_Component_Declaration (Loc, 9560 Defining_Identifier => 9561 Make_Defining_Identifier (Loc, Name_uObject), 9562 Component_Definition => 9563 Make_Component_Definition (Loc, 9564 Aliased_Present => True, 9565 Subtype_Indication => Protection_Subtype)); 9566 end; 9567 9568 -- Put the _Object component after the private component so that it 9569 -- be finalized early as required by 9.4 (20) 9570 9571 Append_To (Cdecls, Object_Comp); 9572 end if; 9573 9574 -- Analyze the record declaration immediately after construction, 9575 -- because the initialization procedure is needed for single object 9576 -- declarations before the next entity is analyzed (the freeze call 9577 -- that generates this initialization procedure is found below). 9578 9579 Analyze (Rec_Decl, Suppress => All_Checks); 9580 9581 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before 9582 -- the corresponding record is frozen. If any wrappers are generated, 9583 -- Current_Node is updated accordingly. 9584 9585 if Ada_Version >= Ada_2005 then 9586 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node); 9587 end if; 9588 9589 -- Collect pointers to entry bodies and their barriers, to be placed 9590 -- in the Entry_Bodies_Array for the type. For each entry/family we 9591 -- add an expression to the aggregate which is the initial value of 9592 -- this array. The array is declared after all protected subprograms. 9593 9594 if Has_Entries (Prot_Typ) then 9595 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); 9596 else 9597 Entries_Aggr := Empty; 9598 end if; 9599 9600 -- Build two new procedure specifications for each protected subprogram; 9601 -- one to call from outside the object and one to call from inside. 9602 -- Build a barrier function and an entry body action procedure 9603 -- specification for each protected entry. Initialize the entry body 9604 -- array. If subprogram is flagged as eliminated, do not generate any 9605 -- internal operations. 9606 9607 E_Count := 0; 9608 Comp := First (Visible_Declarations (Pdef)); 9609 while Present (Comp) loop 9610 if Nkind (Comp) = N_Subprogram_Declaration then 9611 Sub := 9612 Make_Subprogram_Declaration (Loc, 9613 Specification => 9614 Build_Protected_Sub_Specification 9615 (Comp, Prot_Typ, Unprotected_Mode)); 9616 9617 Insert_After (Current_Node, Sub); 9618 Analyze (Sub); 9619 9620 Set_Protected_Body_Subprogram 9621 (Defining_Unit_Name (Specification (Comp)), 9622 Defining_Unit_Name (Specification (Sub))); 9623 Check_Inlining (Defining_Unit_Name (Specification (Comp))); 9624 9625 -- Make the protected version of the subprogram available for 9626 -- expansion of external calls. 9627 9628 Current_Node := Sub; 9629 9630 Sub := 9631 Make_Subprogram_Declaration (Loc, 9632 Specification => 9633 Build_Protected_Sub_Specification 9634 (Comp, Prot_Typ, Protected_Mode)); 9635 9636 Insert_After (Current_Node, Sub); 9637 Analyze (Sub); 9638 9639 Current_Node := Sub; 9640 9641 -- Generate an overriding primitive operation specification for 9642 -- this subprogram if the protected type implements an interface 9643 -- and Build_Wrapper_Spec did not generate its wrapper. 9644 9645 if Ada_Version >= Ada_2005 9646 and then 9647 Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) 9648 then 9649 declare 9650 Found : Boolean := False; 9651 Prim_Elmt : Elmt_Id; 9652 Prim_Op : Node_Id; 9653 9654 begin 9655 Prim_Elmt := 9656 First_Elmt 9657 (Primitive_Operations 9658 (Corresponding_Record_Type (Prot_Typ))); 9659 9660 while Present (Prim_Elmt) loop 9661 Prim_Op := Node (Prim_Elmt); 9662 9663 if Is_Primitive_Wrapper (Prim_Op) 9664 and then Wrapped_Entity (Prim_Op) = 9665 Defining_Entity (Specification (Comp)) 9666 then 9667 Found := True; 9668 exit; 9669 end if; 9670 9671 Next_Elmt (Prim_Elmt); 9672 end loop; 9673 9674 if not Found then 9675 Sub := 9676 Make_Subprogram_Declaration (Loc, 9677 Specification => 9678 Build_Protected_Sub_Specification 9679 (Comp, Prot_Typ, Dispatching_Mode)); 9680 9681 Insert_After (Current_Node, Sub); 9682 Analyze (Sub); 9683 9684 Current_Node := Sub; 9685 end if; 9686 end; 9687 end if; 9688 9689 -- If a pragma Interrupt_Handler applies, build and add a call to 9690 -- Register_Interrupt_Handler to the freezing actions of the 9691 -- protected version (Current_Node) of the subprogram: 9692 9693 -- system.interrupts.register_interrupt_handler 9694 -- (prot_procP'address); 9695 9696 if not Restricted_Profile 9697 and then Is_Interrupt_Handler 9698 (Defining_Unit_Name (Specification (Comp))) 9699 then 9700 Register_Handler; 9701 end if; 9702 9703 elsif Nkind (Comp) = N_Entry_Declaration then 9704 Expand_Entry_Declaration (Comp); 9705 end if; 9706 9707 Next (Comp); 9708 end loop; 9709 9710 -- If there are some private entry declarations, expand it as if they 9711 -- were visible entries. 9712 9713 if Present (Private_Declarations (Pdef)) then 9714 Comp := First (Private_Declarations (Pdef)); 9715 while Present (Comp) loop 9716 if Nkind (Comp) = N_Entry_Declaration then 9717 Expand_Entry_Declaration (Comp); 9718 end if; 9719 9720 Next (Comp); 9721 end loop; 9722 end if; 9723 9724 -- Create the declaration of an array object which contains the values 9725 -- of aspect/pragma Max_Queue_Length for all entries of the protected 9726 -- type. This object is later passed to the appropriate protected object 9727 -- initialization routine. 9728 9729 if Has_Entries (Prot_Typ) 9730 and then Corresponding_Runtime_Package (Prot_Typ) = 9731 System_Tasking_Protected_Objects_Entries 9732 then 9733 declare 9734 Count : Int; 9735 Item : Entity_Id; 9736 Max_Vals : Node_Id; 9737 Maxes : List_Id; 9738 Maxes_Id : Entity_Id; 9739 Need_Array : Boolean := False; 9740 9741 begin 9742 -- First check if there is any Max_Queue_Length pragma 9743 9744 Item := First_Entity (Prot_Typ); 9745 while Present (Item) loop 9746 if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then 9747 Need_Array := True; 9748 exit; 9749 end if; 9750 9751 Next_Entity (Item); 9752 end loop; 9753 9754 -- Gather the Max_Queue_Length values of all entries in a list. A 9755 -- value of zero indicates that the entry has no limitation on its 9756 -- queue length. 9757 9758 if Need_Array then 9759 Count := 0; 9760 Item := First_Entity (Prot_Typ); 9761 Maxes := New_List; 9762 while Present (Item) loop 9763 if Is_Entry (Item) then 9764 Count := Count + 1; 9765 Append_To (Maxes, 9766 Make_Integer_Literal 9767 (Loc, Get_Max_Queue_Length (Item))); 9768 end if; 9769 9770 Next_Entity (Item); 9771 end loop; 9772 9773 -- Create the declaration of the array object. Generate: 9774 9775 -- Maxes_Id : aliased constant 9776 -- Protected_Entry_Queue_Max_Array 9777 -- (1 .. Count) := (..., ...); 9778 9779 Maxes_Id := 9780 Make_Defining_Identifier (Loc, 9781 Chars => New_External_Name (Chars (Prot_Typ), 'B')); 9782 9783 Max_Vals := 9784 Make_Object_Declaration (Loc, 9785 Defining_Identifier => Maxes_Id, 9786 Aliased_Present => True, 9787 Constant_Present => True, 9788 Object_Definition => 9789 Make_Subtype_Indication (Loc, 9790 Subtype_Mark => 9791 New_Occurrence_Of 9792 (RTE (RE_Protected_Entry_Queue_Max_Array), Loc), 9793 Constraint => 9794 Make_Index_Or_Discriminant_Constraint (Loc, 9795 Constraints => New_List ( 9796 Make_Range (Loc, 9797 Make_Integer_Literal (Loc, 1), 9798 Make_Integer_Literal (Loc, Count))))), 9799 Expression => Make_Aggregate (Loc, Maxes)); 9800 9801 -- A pointer to this array will be placed in the corresponding 9802 -- record by its initialization procedure so this needs to be 9803 -- analyzed here. 9804 9805 Insert_After (Current_Node, Max_Vals); 9806 Current_Node := Max_Vals; 9807 Analyze (Max_Vals); 9808 9809 Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxes_Id); 9810 end if; 9811 end; 9812 end if; 9813 9814 -- Emit declaration for Entry_Bodies_Array, now that the addresses of 9815 -- all protected subprograms have been collected. 9816 9817 if Has_Entries (Prot_Typ) then 9818 Body_Id := 9819 Make_Defining_Identifier (Sloc (Prot_Typ), 9820 Chars => New_External_Name (Chars (Prot_Typ), 'A')); 9821 9822 case Corresponding_Runtime_Package (Prot_Typ) is 9823 when System_Tasking_Protected_Objects_Entries => 9824 Expr := Entries_Aggr; 9825 Obj_Def := 9826 Make_Subtype_Indication (Loc, 9827 Subtype_Mark => 9828 New_Occurrence_Of 9829 (RTE (RE_Protected_Entry_Body_Array), Loc), 9830 Constraint => 9831 Make_Index_Or_Discriminant_Constraint (Loc, 9832 Constraints => New_List ( 9833 Make_Range (Loc, 9834 Make_Integer_Literal (Loc, 1), 9835 Make_Integer_Literal (Loc, E_Count))))); 9836 9837 when System_Tasking_Protected_Objects_Single_Entry => 9838 Expr := Remove_Head (Expressions (Entries_Aggr)); 9839 Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc); 9840 9841 when others => 9842 raise Program_Error; 9843 end case; 9844 9845 Body_Arr := 9846 Make_Object_Declaration (Loc, 9847 Defining_Identifier => Body_Id, 9848 Aliased_Present => True, 9849 Constant_Present => True, 9850 Object_Definition => Obj_Def, 9851 Expression => Expr); 9852 9853 -- A pointer to this array will be placed in the corresponding record 9854 -- by its initialization procedure so this needs to be analyzed here. 9855 9856 Insert_After (Current_Node, Body_Arr); 9857 Current_Node := Body_Arr; 9858 Analyze (Body_Arr); 9859 9860 Set_Entry_Bodies_Array (Prot_Typ, Body_Id); 9861 9862 -- Finally, build the function that maps an entry index into the 9863 -- corresponding body. A pointer to this function is placed in each 9864 -- object of the type. Except for a ravenscar-like profile (no abort, 9865 -- no entry queue, 1 entry) 9866 9867 if Corresponding_Runtime_Package (Prot_Typ) = 9868 System_Tasking_Protected_Objects_Entries 9869 then 9870 Sub := 9871 Make_Subprogram_Declaration (Loc, 9872 Specification => Build_Find_Body_Index_Spec (Prot_Typ)); 9873 9874 Insert_After (Current_Node, Sub); 9875 Analyze (Sub); 9876 end if; 9877 end if; 9878 end Expand_N_Protected_Type_Declaration; 9879 9880 -------------------------------- 9881 -- Expand_N_Requeue_Statement -- 9882 -------------------------------- 9883 9884 -- A nondispatching requeue statement is expanded into one of four GNARLI 9885 -- operations, depending on the source and destination (task or protected 9886 -- object). A dispatching requeue statement is expanded into a call to the 9887 -- predefined primitive _Disp_Requeue. In addition, code is generated to 9888 -- jump around the remainder of processing for the original entry and, if 9889 -- the destination is (different) protected object, to attempt to service 9890 -- it. The following illustrates the various cases: 9891 9892 -- procedure entE 9893 -- (O : System.Address; 9894 -- P : System.Address; 9895 -- E : Protected_Entry_Index) 9896 -- is 9897 -- <discriminant renamings> 9898 -- <private object renamings> 9899 -- type poVP is access poV; 9900 -- _object : ptVP := ptVP!(O); 9901 9902 -- begin 9903 -- begin 9904 -- <start of statement sequence for entry> 9905 9906 -- -- Requeue from one protected entry body to another protected 9907 -- -- entry. 9908 9909 -- Requeue_Protected_Entry ( 9910 -- _object._object'Access, 9911 -- new._object'Access, 9912 -- E, 9913 -- Abort_Present); 9914 -- return; 9915 9916 -- <some more of the statement sequence for entry> 9917 9918 -- -- Requeue from an entry body to a task entry 9919 9920 -- Requeue_Protected_To_Task_Entry ( 9921 -- New._task_id, 9922 -- E, 9923 -- Abort_Present); 9924 -- return; 9925 9926 -- <rest of statement sequence for entry> 9927 -- Complete_Entry_Body (_object._object); 9928 9929 -- exception 9930 -- when all others => 9931 -- Exceptional_Complete_Entry_Body ( 9932 -- _object._object, Get_GNAT_Exception); 9933 -- end; 9934 -- end entE; 9935 9936 -- Requeue of a task entry call to a task entry 9937 9938 -- Accept_Call (E, Ann); 9939 -- <start of statement sequence for accept statement> 9940 -- Requeue_Task_Entry (New._task_id, E, Abort_Present); 9941 -- goto Lnn; 9942 -- <rest of statement sequence for accept statement> 9943 -- <<Lnn>> 9944 -- Complete_Rendezvous; 9945 9946 -- exception 9947 -- when all others => 9948 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9949 9950 -- Requeue of a task entry call to a protected entry 9951 9952 -- Accept_Call (E, Ann); 9953 -- <start of statement sequence for accept statement> 9954 -- Requeue_Task_To_Protected_Entry ( 9955 -- new._object'Access, 9956 -- E, 9957 -- Abort_Present); 9958 -- newS (new, Pnn); 9959 -- goto Lnn; 9960 -- <rest of statement sequence for accept statement> 9961 -- <<Lnn>> 9962 -- Complete_Rendezvous; 9963 9964 -- exception 9965 -- when all others => 9966 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9967 9968 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9969 -- marked by pragma Implemented (XXX, By_Entry). 9970 9971 -- The requeue is inside a protected entry: 9972 9973 -- procedure entE 9974 -- (O : System.Address; 9975 -- P : System.Address; 9976 -- E : Protected_Entry_Index) 9977 -- is 9978 -- <discriminant renamings> 9979 -- <private object renamings> 9980 -- type poVP is access poV; 9981 -- _object : ptVP := ptVP!(O); 9982 9983 -- begin 9984 -- begin 9985 -- <start of statement sequence for entry> 9986 9987 -- _Disp_Requeue 9988 -- (<interface class-wide object>, 9989 -- True, 9990 -- _object'Address, 9991 -- Ada.Tags.Get_Offset_Index 9992 -- (Tag (_object), 9993 -- <interface dispatch table index of target entry>), 9994 -- Abort_Present); 9995 -- return; 9996 9997 -- <rest of statement sequence for entry> 9998 -- Complete_Entry_Body (_object._object); 9999 10000 -- exception 10001 -- when all others => 10002 -- Exceptional_Complete_Entry_Body ( 10003 -- _object._object, Get_GNAT_Exception); 10004 -- end; 10005 -- end entE; 10006 10007 -- The requeue is inside a task entry: 10008 10009 -- Accept_Call (E, Ann); 10010 -- <start of statement sequence for accept statement> 10011 -- _Disp_Requeue 10012 -- (<interface class-wide object>, 10013 -- False, 10014 -- null, 10015 -- Ada.Tags.Get_Offset_Index 10016 -- (Tag (_object), 10017 -- <interface dispatch table index of target entrt>), 10018 -- Abort_Present); 10019 -- newS (new, Pnn); 10020 -- goto Lnn; 10021 -- <rest of statement sequence for accept statement> 10022 -- <<Lnn>> 10023 -- Complete_Rendezvous; 10024 10025 -- exception 10026 -- when all others => 10027 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 10028 10029 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 10030 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue 10031 -- statement is replaced by a dispatching call with actual parameters taken 10032 -- from the inner-most accept statement or entry body. 10033 10034 -- Target.Primitive (Param1, ..., ParamN); 10035 10036 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 10037 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked 10038 -- at all. 10039 10040 -- declare 10041 -- S : constant Offset_Index := 10042 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename)); 10043 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S); 10044 10045 -- begin 10046 -- if C = POK_Protected_Entry 10047 -- or else C = POK_Task_Entry 10048 -- then 10049 -- <statements for dispatching requeue> 10050 10051 -- elsif C = POK_Protected_Procedure then 10052 -- <dispatching call equivalent> 10053 10054 -- else 10055 -- raise Program_Error; 10056 -- end if; 10057 -- end; 10058 10059 procedure Expand_N_Requeue_Statement (N : Node_Id) is 10060 Loc : constant Source_Ptr := Sloc (N); 10061 Conc_Typ : Entity_Id; 10062 Concval : Node_Id; 10063 Ename : Node_Id; 10064 Enc_Subp : Entity_Id; 10065 Index : Node_Id; 10066 Old_Typ : Entity_Id; 10067 10068 function Build_Dispatching_Call_Equivalent return Node_Id; 10069 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 10070 -- the form Concval.Ename. It is statically known that Ename is allowed 10071 -- to be implemented by a protected procedure. Create a dispatching call 10072 -- equivalent of Concval.Ename taking the actual parameters from the 10073 -- inner-most accept statement or entry body. 10074 10075 function Build_Dispatching_Requeue return Node_Id; 10076 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 10077 -- the form Concval.Ename. It is statically known that Ename is allowed 10078 -- to be implemented by a protected or a task entry. Create a call to 10079 -- primitive _Disp_Requeue which handles the low-level actions. 10080 10081 function Build_Dispatching_Requeue_To_Any return Node_Id; 10082 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 10083 -- the form Concval.Ename. Ename is either marked by pragma Implemented 10084 -- (XXX, By_Any | Optional) or not marked at all. Create a block which 10085 -- determines at runtime whether Ename denotes an entry or a procedure 10086 -- and perform the appropriate kind of dispatching select. 10087 10088 function Build_Normal_Requeue return Node_Id; 10089 -- N denotes a nondispatching requeue statement to either a task or a 10090 -- protected entry. Build the appropriate runtime call to perform the 10091 -- action. 10092 10093 function Build_Skip_Statement (Search : Node_Id) return Node_Id; 10094 -- For a protected entry, create a return statement to skip the rest of 10095 -- the entry body. Otherwise, create a goto statement to skip the rest 10096 -- of a task accept statement. The lookup for the enclosing entry body 10097 -- or accept statement starts from Search. 10098 10099 --------------------------------------- 10100 -- Build_Dispatching_Call_Equivalent -- 10101 --------------------------------------- 10102 10103 function Build_Dispatching_Call_Equivalent return Node_Id is 10104 Call_Ent : constant Entity_Id := Entity (Ename); 10105 Obj : constant Node_Id := Original_Node (Concval); 10106 Acc_Ent : Node_Id; 10107 Actuals : List_Id; 10108 Formal : Node_Id; 10109 Formals : List_Id; 10110 10111 begin 10112 -- Climb the parent chain looking for the inner-most entry body or 10113 -- accept statement. 10114 10115 Acc_Ent := N; 10116 while Present (Acc_Ent) 10117 and then Nkind (Acc_Ent) not in N_Accept_Statement | N_Entry_Body 10118 loop 10119 Acc_Ent := Parent (Acc_Ent); 10120 end loop; 10121 10122 -- A requeue statement should be housed inside an entry body or an 10123 -- accept statement at some level. If this is not the case, then the 10124 -- tree is malformed. 10125 10126 pragma Assert (Present (Acc_Ent)); 10127 10128 -- Recover the list of formal parameters 10129 10130 if Nkind (Acc_Ent) = N_Entry_Body then 10131 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent); 10132 end if; 10133 10134 Formals := Parameter_Specifications (Acc_Ent); 10135 10136 -- Create the actual parameters for the dispatching call. These are 10137 -- simply copies of the entry body or accept statement formals in the 10138 -- same order as they appear. 10139 10140 Actuals := No_List; 10141 10142 if Present (Formals) then 10143 Actuals := New_List; 10144 Formal := First (Formals); 10145 while Present (Formal) loop 10146 Append_To (Actuals, 10147 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 10148 Next (Formal); 10149 end loop; 10150 end if; 10151 10152 -- Generate: 10153 -- Obj.Call_Ent (Actuals); 10154 10155 return 10156 Make_Procedure_Call_Statement (Loc, 10157 Name => 10158 Make_Selected_Component (Loc, 10159 Prefix => Make_Identifier (Loc, Chars (Obj)), 10160 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))), 10161 10162 Parameter_Associations => Actuals); 10163 end Build_Dispatching_Call_Equivalent; 10164 10165 ------------------------------- 10166 -- Build_Dispatching_Requeue -- 10167 ------------------------------- 10168 10169 function Build_Dispatching_Requeue return Node_Id is 10170 Params : constant List_Id := New_List; 10171 10172 begin 10173 -- Process the "with abort" parameter 10174 10175 Prepend_To (Params, 10176 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10177 10178 -- Process the entry wrapper's position in the primary dispatch 10179 -- table parameter. Generate: 10180 10181 -- Ada.Tags.Get_Entry_Index 10182 -- (T => To_Tag_Ptr (Obj'Address).all, 10183 -- Position => 10184 -- Ada.Tags.Get_Offset_Index 10185 -- (Ada.Tags.Tag (Concval), 10186 -- <interface dispatch table position of Ename>)); 10187 10188 -- Note that Obj'Address is recursively expanded into a call to 10189 -- Base_Address (Obj). 10190 10191 if Tagged_Type_Expansion then 10192 Prepend_To (Params, 10193 Make_Function_Call (Loc, 10194 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 10195 Parameter_Associations => New_List ( 10196 10197 Make_Explicit_Dereference (Loc, 10198 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 10199 Make_Attribute_Reference (Loc, 10200 Prefix => New_Copy_Tree (Concval), 10201 Attribute_Name => Name_Address))), 10202 10203 Make_Function_Call (Loc, 10204 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 10205 Parameter_Associations => New_List ( 10206 Unchecked_Convert_To (RTE (RE_Tag), Concval), 10207 Make_Integer_Literal (Loc, 10208 DT_Position (Entity (Ename)))))))); 10209 10210 -- VM targets 10211 10212 else 10213 Prepend_To (Params, 10214 Make_Function_Call (Loc, 10215 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 10216 Parameter_Associations => New_List ( 10217 10218 Make_Attribute_Reference (Loc, 10219 Prefix => Concval, 10220 Attribute_Name => Name_Tag), 10221 10222 Make_Function_Call (Loc, 10223 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 10224 10225 Parameter_Associations => New_List ( 10226 10227 -- Obj_Tag 10228 10229 Make_Attribute_Reference (Loc, 10230 Prefix => Concval, 10231 Attribute_Name => Name_Tag), 10232 10233 -- Tag_Typ 10234 10235 Make_Attribute_Reference (Loc, 10236 Prefix => New_Occurrence_Of (Etype (Concval), Loc), 10237 Attribute_Name => Name_Tag), 10238 10239 -- Position 10240 10241 Make_Integer_Literal (Loc, 10242 DT_Position (Entity (Ename)))))))); 10243 end if; 10244 10245 -- Specific actuals for protected to XXX requeue 10246 10247 if Is_Protected_Type (Old_Typ) then 10248 Prepend_To (Params, 10249 Make_Attribute_Reference (Loc, -- _object'Address 10250 Prefix => 10251 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10252 Attribute_Name => Name_Address)); 10253 10254 Prepend_To (Params, -- True 10255 New_Occurrence_Of (Standard_True, Loc)); 10256 10257 -- Specific actuals for task to XXX requeue 10258 10259 else 10260 pragma Assert (Is_Task_Type (Old_Typ)); 10261 10262 Prepend_To (Params, -- null 10263 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 10264 10265 Prepend_To (Params, -- False 10266 New_Occurrence_Of (Standard_False, Loc)); 10267 end if; 10268 10269 -- Add the object parameter 10270 10271 Prepend_To (Params, New_Copy_Tree (Concval)); 10272 10273 -- Generate: 10274 -- _Disp_Requeue (<Params>); 10275 10276 -- Find entity for Disp_Requeue operation, which belongs to 10277 -- the type and may not be directly visible. 10278 10279 declare 10280 Elmt : Elmt_Id; 10281 Op : Entity_Id := Empty; 10282 10283 begin 10284 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ))); 10285 while Present (Elmt) loop 10286 Op := Node (Elmt); 10287 exit when Chars (Op) = Name_uDisp_Requeue; 10288 Next_Elmt (Elmt); 10289 end loop; 10290 10291 pragma Assert (Present (Op)); 10292 10293 return 10294 Make_Procedure_Call_Statement (Loc, 10295 Name => New_Occurrence_Of (Op, Loc), 10296 Parameter_Associations => Params); 10297 end; 10298 end Build_Dispatching_Requeue; 10299 10300 -------------------------------------- 10301 -- Build_Dispatching_Requeue_To_Any -- 10302 -------------------------------------- 10303 10304 function Build_Dispatching_Requeue_To_Any return Node_Id is 10305 Call_Ent : constant Entity_Id := Entity (Ename); 10306 Obj : constant Node_Id := Original_Node (Concval); 10307 Skip : constant Node_Id := Build_Skip_Statement (N); 10308 C : Entity_Id; 10309 Decls : List_Id; 10310 S : Entity_Id; 10311 Stmts : List_Id; 10312 10313 begin 10314 Decls := New_List; 10315 Stmts := New_List; 10316 10317 -- Dispatch table slot processing, generate: 10318 -- S : Integer; 10319 10320 S := Build_S (Loc, Decls); 10321 10322 -- Call kind processing, generate: 10323 -- C : Ada.Tags.Prim_Op_Kind; 10324 10325 C := Build_C (Loc, Decls); 10326 10327 -- Generate: 10328 -- S := Ada.Tags.Get_Offset_Index 10329 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent)); 10330 10331 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent)); 10332 10333 -- Generate: 10334 -- _Disp_Get_Prim_Op_Kind (Obj, S, C); 10335 10336 Append_To (Stmts, 10337 Make_Procedure_Call_Statement (Loc, 10338 Name => 10339 New_Occurrence_Of ( 10340 Find_Prim_Op (Etype (Etype (Obj)), 10341 Name_uDisp_Get_Prim_Op_Kind), 10342 Loc), 10343 Parameter_Associations => New_List ( 10344 New_Copy_Tree (Obj), 10345 New_Occurrence_Of (S, Loc), 10346 New_Occurrence_Of (C, Loc)))); 10347 10348 Append_To (Stmts, 10349 10350 -- if C = POK_Protected_Entry 10351 -- or else C = POK_Task_Entry 10352 -- then 10353 10354 Make_Implicit_If_Statement (N, 10355 Condition => 10356 Make_Op_Or (Loc, 10357 Left_Opnd => 10358 Make_Op_Eq (Loc, 10359 Left_Opnd => 10360 New_Occurrence_Of (C, Loc), 10361 Right_Opnd => 10362 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 10363 10364 Right_Opnd => 10365 Make_Op_Eq (Loc, 10366 Left_Opnd => 10367 New_Occurrence_Of (C, Loc), 10368 Right_Opnd => 10369 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 10370 10371 -- Dispatching requeue equivalent 10372 10373 Then_Statements => New_List ( 10374 Build_Dispatching_Requeue, 10375 Skip), 10376 10377 -- elsif C = POK_Protected_Procedure then 10378 10379 Elsif_Parts => New_List ( 10380 Make_Elsif_Part (Loc, 10381 Condition => 10382 Make_Op_Eq (Loc, 10383 Left_Opnd => 10384 New_Occurrence_Of (C, Loc), 10385 Right_Opnd => 10386 New_Occurrence_Of ( 10387 RTE (RE_POK_Protected_Procedure), Loc)), 10388 10389 -- Dispatching call equivalent 10390 10391 Then_Statements => New_List ( 10392 Build_Dispatching_Call_Equivalent))), 10393 10394 -- else 10395 -- raise Program_Error; 10396 -- end if; 10397 10398 Else_Statements => New_List ( 10399 Make_Raise_Program_Error (Loc, 10400 Reason => PE_Explicit_Raise)))); 10401 10402 -- Wrap everything into a block 10403 10404 return 10405 Make_Block_Statement (Loc, 10406 Declarations => Decls, 10407 Handled_Statement_Sequence => 10408 Make_Handled_Sequence_Of_Statements (Loc, 10409 Statements => Stmts)); 10410 end Build_Dispatching_Requeue_To_Any; 10411 10412 -------------------------- 10413 -- Build_Normal_Requeue -- 10414 -------------------------- 10415 10416 function Build_Normal_Requeue return Node_Id is 10417 Params : constant List_Id := New_List; 10418 Param : Node_Id; 10419 RT_Call : Node_Id; 10420 10421 begin 10422 -- Process the "with abort" parameter 10423 10424 Prepend_To (Params, 10425 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10426 10427 -- Add the index expression to the parameters. It is common among all 10428 -- four cases. 10429 10430 Prepend_To (Params, 10431 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ)); 10432 10433 if Is_Protected_Type (Old_Typ) then 10434 declare 10435 Self_Param : Node_Id; 10436 10437 begin 10438 Self_Param := 10439 Make_Attribute_Reference (Loc, 10440 Prefix => 10441 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10442 Attribute_Name => 10443 Name_Unchecked_Access); 10444 10445 -- Protected to protected requeue 10446 10447 if Is_Protected_Type (Conc_Typ) then 10448 RT_Call := 10449 New_Occurrence_Of ( 10450 RTE (RE_Requeue_Protected_Entry), Loc); 10451 10452 Param := 10453 Make_Attribute_Reference (Loc, 10454 Prefix => 10455 Concurrent_Ref (Concval), 10456 Attribute_Name => 10457 Name_Unchecked_Access); 10458 10459 -- Protected to task requeue 10460 10461 else pragma Assert (Is_Task_Type (Conc_Typ)); 10462 RT_Call := 10463 New_Occurrence_Of ( 10464 RTE (RE_Requeue_Protected_To_Task_Entry), Loc); 10465 10466 Param := Concurrent_Ref (Concval); 10467 end if; 10468 10469 Prepend_To (Params, Param); 10470 Prepend_To (Params, Self_Param); 10471 end; 10472 10473 else pragma Assert (Is_Task_Type (Old_Typ)); 10474 10475 -- Task to protected requeue 10476 10477 if Is_Protected_Type (Conc_Typ) then 10478 RT_Call := 10479 New_Occurrence_Of ( 10480 RTE (RE_Requeue_Task_To_Protected_Entry), Loc); 10481 10482 Param := 10483 Make_Attribute_Reference (Loc, 10484 Prefix => 10485 Concurrent_Ref (Concval), 10486 Attribute_Name => 10487 Name_Unchecked_Access); 10488 10489 -- Task to task requeue 10490 10491 else pragma Assert (Is_Task_Type (Conc_Typ)); 10492 RT_Call := 10493 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc); 10494 10495 Param := Concurrent_Ref (Concval); 10496 end if; 10497 10498 Prepend_To (Params, Param); 10499 end if; 10500 10501 return 10502 Make_Procedure_Call_Statement (Loc, 10503 Name => RT_Call, 10504 Parameter_Associations => Params); 10505 end Build_Normal_Requeue; 10506 10507 -------------------------- 10508 -- Build_Skip_Statement -- 10509 -------------------------- 10510 10511 function Build_Skip_Statement (Search : Node_Id) return Node_Id is 10512 Skip_Stmt : Node_Id; 10513 10514 begin 10515 -- Build a return statement to skip the rest of the entire body 10516 10517 if Is_Protected_Type (Old_Typ) then 10518 Skip_Stmt := Make_Simple_Return_Statement (Loc); 10519 10520 -- If the requeue is within a task, find the end label of the 10521 -- enclosing accept statement and create a goto statement to it. 10522 10523 else 10524 declare 10525 Acc : Node_Id; 10526 Label : Node_Id; 10527 10528 begin 10529 -- Climb the parent chain looking for the enclosing accept 10530 -- statement. 10531 10532 Acc := Parent (Search); 10533 while Present (Acc) 10534 and then Nkind (Acc) /= N_Accept_Statement 10535 loop 10536 Acc := Parent (Acc); 10537 end loop; 10538 10539 -- The last statement is the second label used for completing 10540 -- the rendezvous the usual way. The label we are looking for 10541 -- is right before it. 10542 10543 Label := 10544 Prev (Last (Statements (Handled_Statement_Sequence (Acc)))); 10545 10546 pragma Assert (Nkind (Label) = N_Label); 10547 10548 -- Generate a goto statement to skip the rest of the accept 10549 10550 Skip_Stmt := 10551 Make_Goto_Statement (Loc, 10552 Name => 10553 New_Occurrence_Of (Entity (Identifier (Label)), Loc)); 10554 end; 10555 end if; 10556 10557 Set_Analyzed (Skip_Stmt); 10558 10559 return Skip_Stmt; 10560 end Build_Skip_Statement; 10561 10562 -- Start of processing for Expand_N_Requeue_Statement 10563 10564 begin 10565 -- Extract the components of the entry call 10566 10567 Extract_Entry (N, Concval, Ename, Index); 10568 Conc_Typ := Etype (Concval); 10569 10570 -- Examine the scope stack in order to find nearest enclosing concurrent 10571 -- type. This will constitute our invocation source. 10572 10573 Old_Typ := Current_Scope; 10574 while Present (Old_Typ) 10575 and then not Is_Concurrent_Type (Old_Typ) 10576 loop 10577 Old_Typ := Scope (Old_Typ); 10578 end loop; 10579 10580 -- Obtain the innermost enclosing callable construct for use in 10581 -- generating a dynamic accessibility check. 10582 10583 Enc_Subp := Current_Scope; 10584 10585 if Ekind (Enc_Subp) not in Entry_Kind | Subprogram_Kind then 10586 Enc_Subp := Enclosing_Subprogram (Enc_Subp); 10587 end if; 10588 10589 -- Generate a dynamic accessibility check on the target object 10590 10591 Insert_Before_And_Analyze (N, 10592 Make_Raise_Program_Error (Loc, 10593 Condition => 10594 Make_Op_Gt (Loc, 10595 Left_Opnd => Accessibility_Level (Name (N), Dynamic_Level), 10596 Right_Opnd => Make_Integer_Literal (Loc, 10597 Scope_Depth (Enc_Subp))), 10598 Reason => PE_Accessibility_Check_Failed)); 10599 10600 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form 10601 -- Concval.Ename where the type of Concval is class-wide concurrent 10602 -- interface. 10603 10604 if Ada_Version >= Ada_2012 10605 and then Present (Concval) 10606 and then Is_Class_Wide_Type (Conc_Typ) 10607 and then Is_Concurrent_Interface (Conc_Typ) 10608 then 10609 declare 10610 Has_Impl : Boolean := False; 10611 Impl_Kind : Name_Id := No_Name; 10612 10613 begin 10614 -- Check whether the Ename is flagged by pragma Implemented 10615 10616 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then 10617 Has_Impl := True; 10618 Impl_Kind := Implementation_Kind (Entity (Ename)); 10619 end if; 10620 10621 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10622 -- an entry. Create a call to predefined primitive _Disp_Requeue. 10623 10624 if Has_Impl and then Impl_Kind = Name_By_Entry then 10625 Rewrite (N, Build_Dispatching_Requeue); 10626 Analyze (N); 10627 Insert_After (N, Build_Skip_Statement (N)); 10628 10629 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10630 -- a protected procedure. In this case the requeue is transformed 10631 -- into a dispatching call. 10632 10633 elsif Has_Impl 10634 and then Impl_Kind = Name_By_Protected_Procedure 10635 then 10636 Rewrite (N, Build_Dispatching_Call_Equivalent); 10637 Analyze (N); 10638 10639 -- The procedure_or_entry_NAME's implementation kind is either 10640 -- By_Any, Optional, or pragma Implemented was not applied at all. 10641 -- In this case a runtime test determines whether Ename denotes an 10642 -- entry or a protected procedure and performs the appropriate 10643 -- call. 10644 10645 else 10646 Rewrite (N, Build_Dispatching_Requeue_To_Any); 10647 Analyze (N); 10648 end if; 10649 end; 10650 10651 -- Processing for regular (nondispatching) requeues 10652 10653 else 10654 Rewrite (N, Build_Normal_Requeue); 10655 Analyze (N); 10656 Insert_After (N, Build_Skip_Statement (N)); 10657 end if; 10658 end Expand_N_Requeue_Statement; 10659 10660 ------------------------------- 10661 -- Expand_N_Selective_Accept -- 10662 ------------------------------- 10663 10664 procedure Expand_N_Selective_Accept (N : Node_Id) is 10665 Loc : constant Source_Ptr := Sloc (N); 10666 Alts : constant List_Id := Select_Alternatives (N); 10667 10668 -- Note: in the below declarations a lot of new lists are allocated 10669 -- unconditionally which may well not end up being used. That's not 10670 -- a good idea since it wastes space gratuitously ??? 10671 10672 Accept_Case : List_Id; 10673 Accept_List : constant List_Id := New_List; 10674 10675 Alt : Node_Id; 10676 Alt_List : constant List_Id := New_List; 10677 Alt_Stats : List_Id; 10678 Ann : Entity_Id := Empty; 10679 10680 Check_Guard : Boolean := True; 10681 10682 Decls : constant List_Id := New_List; 10683 Stats : constant List_Id := New_List; 10684 Body_List : constant List_Id := New_List; 10685 Trailing_List : constant List_Id := New_List; 10686 10687 Choices : List_Id; 10688 Else_Present : Boolean := False; 10689 Terminate_Alt : Node_Id := Empty; 10690 Select_Mode : Node_Id; 10691 10692 Delay_Case : List_Id; 10693 Delay_Count : Integer := 0; 10694 Delay_Val : Entity_Id; 10695 Delay_Index : Entity_Id; 10696 Delay_Min : Entity_Id; 10697 Delay_Num : Pos := 1; 10698 Delay_Alt_List : List_Id := New_List; 10699 Delay_List : constant List_Id := New_List; 10700 D : Entity_Id; 10701 M : Entity_Id; 10702 10703 First_Delay : Boolean := True; 10704 Guard_Open : Entity_Id; 10705 10706 End_Lab : Node_Id; 10707 Index : Pos := 1; 10708 Lab : Node_Id; 10709 Num_Alts : Nat; 10710 Num_Accept : Nat := 0; 10711 Proc : Node_Id; 10712 Time_Type : Entity_Id := Empty; 10713 Select_Call : Node_Id; 10714 10715 Qnam : constant Entity_Id := 10716 Make_Defining_Identifier (Loc, New_External_Name ('S', 0)); 10717 10718 Xnam : constant Entity_Id := 10719 Make_Defining_Identifier (Loc, New_External_Name ('J', 1)); 10720 10721 ----------------------- 10722 -- Local subprograms -- 10723 ----------------------- 10724 10725 function Accept_Or_Raise return List_Id; 10726 -- For the rare case where delay alternatives all have guards, and 10727 -- all of them are closed, it is still possible that there were open 10728 -- accept alternatives with no callers. We must reexamine the 10729 -- Accept_List, and execute a selective wait with no else if some 10730 -- accept is open. If none, we raise program_error. 10731 10732 procedure Add_Accept (Alt : Node_Id); 10733 -- Process a single accept statement in a select alternative. Build 10734 -- procedure for body of accept, and add entry to dispatch table with 10735 -- expression for guard, in preparation for call to run time select. 10736 10737 function Make_And_Declare_Label (Num : Int) return Node_Id; 10738 -- Manufacture a label using Num as a serial number and declare it. 10739 -- The declaration is appended to Decls. The label marks the trailing 10740 -- statements of an accept or delay alternative. 10741 10742 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; 10743 -- Build call to Selective_Wait runtime routine 10744 10745 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); 10746 -- Add code to compare value of delay with previous values, and 10747 -- generate case entry for trailing statements. 10748 10749 procedure Process_Accept_Alternative 10750 (Alt : Node_Id; 10751 Index : Int; 10752 Proc : Node_Id); 10753 -- Add code to call corresponding procedure, and branch to 10754 -- trailing statements, if any. 10755 10756 --------------------- 10757 -- Accept_Or_Raise -- 10758 --------------------- 10759 10760 function Accept_Or_Raise return List_Id is 10761 Cond : Node_Id; 10762 Stats : List_Id; 10763 J : constant Entity_Id := Make_Temporary (Loc, 'J'); 10764 10765 begin 10766 -- We generate the following: 10767 10768 -- for J in q'range loop 10769 -- if q(J).S /=null_task_entry then 10770 -- selective_wait (simple_mode,...); 10771 -- done := True; 10772 -- exit; 10773 -- end if; 10774 -- end loop; 10775 -- 10776 -- if no rendez_vous then 10777 -- raise program_error; 10778 -- end if; 10779 10780 -- Note that the code needs to know that the selector name 10781 -- in an Accept_Alternative is named S. 10782 10783 Cond := Make_Op_Ne (Loc, 10784 Left_Opnd => 10785 Make_Selected_Component (Loc, 10786 Prefix => 10787 Make_Indexed_Component (Loc, 10788 Prefix => New_Occurrence_Of (Qnam, Loc), 10789 Expressions => New_List (New_Occurrence_Of (J, Loc))), 10790 Selector_Name => Make_Identifier (Loc, Name_S)), 10791 Right_Opnd => 10792 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc)); 10793 10794 Stats := New_List ( 10795 Make_Implicit_Loop_Statement (N, 10796 Iteration_Scheme => 10797 Make_Iteration_Scheme (Loc, 10798 Loop_Parameter_Specification => 10799 Make_Loop_Parameter_Specification (Loc, 10800 Defining_Identifier => J, 10801 Discrete_Subtype_Definition => 10802 Make_Attribute_Reference (Loc, 10803 Prefix => New_Occurrence_Of (Qnam, Loc), 10804 Attribute_Name => Name_Range, 10805 Expressions => New_List ( 10806 Make_Integer_Literal (Loc, 1))))), 10807 10808 Statements => New_List ( 10809 Make_Implicit_If_Statement (N, 10810 Condition => Cond, 10811 Then_Statements => New_List ( 10812 Make_Select_Call ( 10813 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)), 10814 Make_Exit_Statement (Loc)))))); 10815 10816 Append_To (Stats, 10817 Make_Raise_Program_Error (Loc, 10818 Condition => Make_Op_Eq (Loc, 10819 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 10820 Right_Opnd => 10821 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 10822 Reason => PE_All_Guards_Closed)); 10823 10824 return Stats; 10825 end Accept_Or_Raise; 10826 10827 ---------------- 10828 -- Add_Accept -- 10829 ---------------- 10830 10831 procedure Add_Accept (Alt : Node_Id) is 10832 Acc_Stm : constant Node_Id := Accept_Statement (Alt); 10833 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm); 10834 Eloc : constant Source_Ptr := Sloc (Ename); 10835 Eent : constant Entity_Id := Entity (Ename); 10836 Index : constant Node_Id := Entry_Index (Acc_Stm); 10837 10838 Call : Node_Id; 10839 Expr : Node_Id; 10840 Null_Body : Node_Id; 10841 PB_Ent : Entity_Id; 10842 Proc_Body : Node_Id; 10843 10844 -- Start of processing for Add_Accept 10845 10846 begin 10847 if No (Ann) then 10848 Ann := Node (Last_Elmt (Accept_Address (Eent))); 10849 end if; 10850 10851 if Present (Condition (Alt)) then 10852 Expr := 10853 Make_If_Expression (Eloc, New_List ( 10854 Condition (Alt), 10855 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)), 10856 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc))); 10857 else 10858 Expr := Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)); 10859 end if; 10860 10861 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then 10862 Null_Body := New_Occurrence_Of (Standard_False, Eloc); 10863 10864 -- Always add call to Abort_Undefer when generating code, since 10865 -- this is what the runtime expects (abort deferred in 10866 -- Selective_Wait). In CodePeer mode this only confuses the 10867 -- analysis with unknown calls, so don't do it. 10868 10869 if not CodePeer_Mode then 10870 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 10871 Insert_Before 10872 (First (Statements (Handled_Statement_Sequence 10873 (Accept_Statement (Alt)))), 10874 Call); 10875 Analyze (Call); 10876 end if; 10877 10878 PB_Ent := 10879 Make_Defining_Identifier (Eloc, 10880 New_External_Name (Chars (Ename), 'A', Num_Accept)); 10881 10882 -- Link the acceptor to the original receiving entry 10883 10884 Set_Ekind (PB_Ent, E_Procedure); 10885 Set_Receiving_Entry (PB_Ent, Eent); 10886 10887 if Comes_From_Source (Alt) then 10888 Set_Debug_Info_Needed (PB_Ent); 10889 end if; 10890 10891 Proc_Body := 10892 Make_Subprogram_Body (Eloc, 10893 Specification => 10894 Make_Procedure_Specification (Eloc, 10895 Defining_Unit_Name => PB_Ent), 10896 Declarations => Declarations (Acc_Stm), 10897 Handled_Statement_Sequence => 10898 Build_Accept_Body (Accept_Statement (Alt))); 10899 10900 Reset_Scopes_To (Proc_Body, PB_Ent); 10901 10902 -- During the analysis of the body of the accept statement, any 10903 -- zero cost exception handler records were collected in the 10904 -- Accept_Handler_Records field of the N_Accept_Alternative node. 10905 -- This is where we move them to where they belong, namely the 10906 -- newly created procedure. 10907 10908 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); 10909 Append (Proc_Body, Body_List); 10910 10911 else 10912 Null_Body := New_Occurrence_Of (Standard_True, Eloc); 10913 10914 -- if accept statement has declarations, insert above, given that 10915 -- we are not creating a body for the accept. 10916 10917 if Present (Declarations (Acc_Stm)) then 10918 Insert_Actions (N, Declarations (Acc_Stm)); 10919 end if; 10920 end if; 10921 10922 Append_To (Accept_List, 10923 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr))); 10924 10925 Num_Accept := Num_Accept + 1; 10926 end Add_Accept; 10927 10928 ---------------------------- 10929 -- Make_And_Declare_Label -- 10930 ---------------------------- 10931 10932 function Make_And_Declare_Label (Num : Int) return Node_Id is 10933 Lab_Id : Node_Id; 10934 10935 begin 10936 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num)); 10937 Lab := 10938 Make_Label (Loc, Lab_Id); 10939 10940 Append_To (Decls, 10941 Make_Implicit_Label_Declaration (Loc, 10942 Defining_Identifier => 10943 Make_Defining_Identifier (Loc, Chars (Lab_Id)), 10944 Label_Construct => Lab)); 10945 10946 return Lab; 10947 end Make_And_Declare_Label; 10948 10949 ---------------------- 10950 -- Make_Select_Call -- 10951 ---------------------- 10952 10953 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is 10954 Params : constant List_Id := New_List; 10955 10956 begin 10957 Append_To (Params, 10958 Make_Attribute_Reference (Loc, 10959 Prefix => New_Occurrence_Of (Qnam, Loc), 10960 Attribute_Name => Name_Unchecked_Access)); 10961 Append_To (Params, Select_Mode); 10962 Append_To (Params, New_Occurrence_Of (Ann, Loc)); 10963 Append_To (Params, New_Occurrence_Of (Xnam, Loc)); 10964 10965 return 10966 Make_Procedure_Call_Statement (Loc, 10967 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc), 10968 Parameter_Associations => Params); 10969 end Make_Select_Call; 10970 10971 -------------------------------- 10972 -- Process_Accept_Alternative -- 10973 -------------------------------- 10974 10975 procedure Process_Accept_Alternative 10976 (Alt : Node_Id; 10977 Index : Int; 10978 Proc : Node_Id) 10979 is 10980 Astmt : constant Node_Id := Accept_Statement (Alt); 10981 Alt_Stats : List_Id; 10982 10983 begin 10984 Adjust_Condition (Condition (Alt)); 10985 10986 -- Accept with body 10987 10988 if Present (Handled_Statement_Sequence (Astmt)) then 10989 Alt_Stats := 10990 New_List ( 10991 Make_Procedure_Call_Statement (Sloc (Proc), 10992 Name => 10993 New_Occurrence_Of 10994 (Defining_Unit_Name (Specification (Proc)), 10995 Sloc (Proc)))); 10996 10997 -- Accept with no body (followed by trailing statements) 10998 10999 else 11000 declare 11001 Entry_Id : constant Entity_Id := 11002 Entity (Entry_Direct_Name (Accept_Statement (Alt))); 11003 begin 11004 -- Ada 2020 (AI12-0279) 11005 11006 if Has_Yield_Aspect (Entry_Id) 11007 and then RTE_Available (RE_Yield) 11008 then 11009 Alt_Stats := 11010 New_List ( 11011 Make_Procedure_Call_Statement (Sloc (Proc), 11012 New_Occurrence_Of (RTE (RE_Yield), Sloc (Proc)))); 11013 else 11014 Alt_Stats := Empty_List; 11015 end if; 11016 end; 11017 end if; 11018 11019 Ensure_Statement_Present (Sloc (Astmt), Alt); 11020 11021 -- After the call, if any, branch to trailing statements, if any. 11022 -- We create a label for each, as well as the corresponding label 11023 -- declaration. 11024 11025 if not Is_Empty_List (Statements (Alt)) then 11026 Lab := Make_And_Declare_Label (Index); 11027 Append (Lab, Trailing_List); 11028 Append_List (Statements (Alt), Trailing_List); 11029 Append_To (Trailing_List, 11030 Make_Goto_Statement (Loc, 11031 Name => New_Copy (Identifier (End_Lab)))); 11032 11033 else 11034 Lab := End_Lab; 11035 end if; 11036 11037 Append_To (Alt_Stats, 11038 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab)))); 11039 11040 Append_To (Alt_List, 11041 Make_Case_Statement_Alternative (Loc, 11042 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)), 11043 Statements => Alt_Stats)); 11044 end Process_Accept_Alternative; 11045 11046 ------------------------------- 11047 -- Process_Delay_Alternative -- 11048 ------------------------------- 11049 11050 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is 11051 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt)); 11052 Cond : Node_Id; 11053 Delay_Alt : List_Id; 11054 11055 begin 11056 -- Deal with C/Fortran boolean as delay condition 11057 11058 Adjust_Condition (Condition (Alt)); 11059 11060 -- Determine the smallest specified delay 11061 11062 -- for each delay alternative generate: 11063 11064 -- if guard-expression then 11065 -- Delay_Val := delay-expression; 11066 -- Guard_Open := True; 11067 -- if Delay_Val < Delay_Min then 11068 -- Delay_Min := Delay_Val; 11069 -- Delay_Index := Index; 11070 -- end if; 11071 -- end if; 11072 11073 -- The enclosing if-statement is omitted if there is no guard 11074 11075 if Delay_Count = 1 or else First_Delay then 11076 First_Delay := False; 11077 11078 Delay_Alt := New_List ( 11079 Make_Assignment_Statement (Loc, 11080 Name => New_Occurrence_Of (Delay_Min, Loc), 11081 Expression => Expression (Delay_Statement (Alt)))); 11082 11083 if Delay_Count > 1 then 11084 Append_To (Delay_Alt, 11085 Make_Assignment_Statement (Loc, 11086 Name => New_Occurrence_Of (Delay_Index, Loc), 11087 Expression => Make_Integer_Literal (Loc, Index))); 11088 end if; 11089 11090 else 11091 Delay_Alt := New_List ( 11092 Make_Assignment_Statement (Loc, 11093 Name => New_Occurrence_Of (Delay_Val, Loc), 11094 Expression => Expression (Delay_Statement (Alt)))); 11095 11096 if Time_Type = Standard_Duration then 11097 Cond := 11098 Make_Op_Lt (Loc, 11099 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc), 11100 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc)); 11101 11102 else 11103 -- The scope of the time type must define a comparison 11104 -- operator. The scope itself may not be visible, so we 11105 -- construct a node with entity information to insure that 11106 -- semantic analysis can find the proper operator. 11107 11108 Cond := 11109 Make_Function_Call (Loc, 11110 Name => Make_Selected_Component (Loc, 11111 Prefix => 11112 New_Occurrence_Of (Scope (Time_Type), Loc), 11113 Selector_Name => 11114 Make_Operator_Symbol (Loc, 11115 Chars => Name_Op_Lt, 11116 Strval => No_String)), 11117 Parameter_Associations => 11118 New_List ( 11119 New_Occurrence_Of (Delay_Val, Loc), 11120 New_Occurrence_Of (Delay_Min, Loc))); 11121 11122 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type)); 11123 end if; 11124 11125 Append_To (Delay_Alt, 11126 Make_Implicit_If_Statement (N, 11127 Condition => Cond, 11128 Then_Statements => New_List ( 11129 Make_Assignment_Statement (Loc, 11130 Name => New_Occurrence_Of (Delay_Min, Loc), 11131 Expression => New_Occurrence_Of (Delay_Val, Loc)), 11132 11133 Make_Assignment_Statement (Loc, 11134 Name => New_Occurrence_Of (Delay_Index, Loc), 11135 Expression => Make_Integer_Literal (Loc, Index))))); 11136 end if; 11137 11138 if Check_Guard then 11139 Append_To (Delay_Alt, 11140 Make_Assignment_Statement (Loc, 11141 Name => New_Occurrence_Of (Guard_Open, Loc), 11142 Expression => New_Occurrence_Of (Standard_True, Loc))); 11143 end if; 11144 11145 if Present (Condition (Alt)) then 11146 Delay_Alt := New_List ( 11147 Make_Implicit_If_Statement (N, 11148 Condition => Condition (Alt), 11149 Then_Statements => Delay_Alt)); 11150 end if; 11151 11152 Append_List (Delay_Alt, Delay_List); 11153 11154 Ensure_Statement_Present (Dloc, Alt); 11155 11156 -- If the delay alternative has a statement part, add choice to the 11157 -- case statements for delays. 11158 11159 if not Is_Empty_List (Statements (Alt)) then 11160 11161 if Delay_Count = 1 then 11162 Append_List (Statements (Alt), Delay_Alt_List); 11163 11164 else 11165 Append_To (Delay_Alt_List, 11166 Make_Case_Statement_Alternative (Loc, 11167 Discrete_Choices => New_List ( 11168 Make_Integer_Literal (Loc, Index)), 11169 Statements => Statements (Alt))); 11170 end if; 11171 11172 elsif Delay_Count = 1 then 11173 11174 -- If the single delay has no trailing statements, add a branch 11175 -- to the exit label to the selective wait. 11176 11177 Delay_Alt_List := New_List ( 11178 Make_Goto_Statement (Loc, 11179 Name => New_Copy (Identifier (End_Lab)))); 11180 11181 end if; 11182 end Process_Delay_Alternative; 11183 11184 -- Start of processing for Expand_N_Selective_Accept 11185 11186 begin 11187 Process_Statements_For_Controlled_Objects (N); 11188 11189 -- First insert some declarations before the select. The first is: 11190 11191 -- Ann : Address 11192 11193 -- This variable holds the parameters passed to the accept body. This 11194 -- declaration has already been inserted by the time we get here by 11195 -- a call to Expand_Accept_Declarations made from the semantics when 11196 -- processing the first accept statement contained in the select. We 11197 -- can find this entity as Accept_Address (E), where E is any of the 11198 -- entries references by contained accept statements. 11199 11200 -- The first step is to scan the list of Selective_Accept_Statements 11201 -- to find this entity, and also count the number of accepts, and 11202 -- determine if terminated, delay or else is present: 11203 11204 Num_Alts := 0; 11205 11206 Alt := First (Alts); 11207 while Present (Alt) loop 11208 Process_Statements_For_Controlled_Objects (Alt); 11209 11210 if Nkind (Alt) = N_Accept_Alternative then 11211 Add_Accept (Alt); 11212 11213 elsif Nkind (Alt) = N_Delay_Alternative then 11214 Delay_Count := Delay_Count + 1; 11215 11216 -- If the delays are relative delays, the delay expressions have 11217 -- type Standard_Duration. Otherwise they must have some time type 11218 -- recognized by GNAT. 11219 11220 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then 11221 Time_Type := Standard_Duration; 11222 else 11223 Time_Type := Etype (Expression (Delay_Statement (Alt))); 11224 11225 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) 11226 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time) 11227 then 11228 null; 11229 else 11230 -- Move this check to sem??? 11231 Error_Msg_NE ( 11232 "& is not a time type (RM 9.6(6))", 11233 Expression (Delay_Statement (Alt)), Time_Type); 11234 Time_Type := Standard_Duration; 11235 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type); 11236 end if; 11237 end if; 11238 11239 if No (Condition (Alt)) then 11240 11241 -- This guard will always be open 11242 11243 Check_Guard := False; 11244 end if; 11245 11246 elsif Nkind (Alt) = N_Terminate_Alternative then 11247 Adjust_Condition (Condition (Alt)); 11248 Terminate_Alt := Alt; 11249 end if; 11250 11251 Num_Alts := Num_Alts + 1; 11252 Next (Alt); 11253 end loop; 11254 11255 Else_Present := Present (Else_Statements (N)); 11256 11257 -- At the same time (see procedure Add_Accept) we build the accept list: 11258 11259 -- Qnn : Accept_List (1 .. num-select) := ( 11260 -- (null-body, entry-index), 11261 -- (null-body, entry-index), 11262 -- .. 11263 -- (null_body, entry-index)); 11264 11265 -- In the above declaration, null-body is True if the corresponding 11266 -- accept has no body, and false otherwise. The entry is either the 11267 -- entry index expression if there is no guard, or if a guard is 11268 -- present, then an if expression of the form: 11269 11270 -- (if guard then entry-index else Null_Task_Entry) 11271 11272 -- If a guard is statically known to be false, the entry can simply 11273 -- be omitted from the accept list. 11274 11275 Append_To (Decls, 11276 Make_Object_Declaration (Loc, 11277 Defining_Identifier => Qnam, 11278 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc), 11279 Aliased_Present => True, 11280 Expression => 11281 Make_Qualified_Expression (Loc, 11282 Subtype_Mark => 11283 New_Occurrence_Of (RTE (RE_Accept_List), Loc), 11284 Expression => 11285 Make_Aggregate (Loc, Expressions => Accept_List)))); 11286 11287 -- Then we declare the variable that holds the index for the accept 11288 -- that will be selected for service: 11289 11290 -- Xnn : Select_Index; 11291 11292 Append_To (Decls, 11293 Make_Object_Declaration (Loc, 11294 Defining_Identifier => Xnam, 11295 Object_Definition => 11296 New_Occurrence_Of (RTE (RE_Select_Index), Loc), 11297 Expression => 11298 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc))); 11299 11300 -- After this follow procedure declarations for each accept body 11301 11302 -- procedure Pnn is 11303 -- begin 11304 -- ... 11305 -- end; 11306 11307 -- where the ... are statements from the corresponding procedure body. 11308 -- No parameters are involved, since the parameters are passed via Ann 11309 -- and the parameter references have already been expanded to be direct 11310 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, 11311 -- any embedded tasking statements (which would normally be illegal in 11312 -- procedures), have been converted to calls to the tasking runtime so 11313 -- there is no problem in putting them into procedures. 11314 11315 -- The original accept statement has been expanded into a block in 11316 -- the same fashion as for simple accepts (see Build_Accept_Body). 11317 11318 -- Note: we don't really need to build these procedures for the case 11319 -- where no delay statement is present, but it is just as easy to 11320 -- build them unconditionally, and not significantly inefficient, 11321 -- since if they are short they will be inlined anyway. 11322 11323 -- The procedure declarations have been assembled in Body_List 11324 11325 -- If delays are present, we must compute the required delay. 11326 -- We first generate the declarations: 11327 11328 -- Delay_Index : Boolean := 0; 11329 -- Delay_Min : Some_Time_Type.Time; 11330 -- Delay_Val : Some_Time_Type.Time; 11331 11332 -- Delay_Index will be set to the index of the minimum delay, i.e. the 11333 -- active delay that is actually chosen as the basis for the possible 11334 -- delay if an immediate rendez-vous is not possible. 11335 11336 -- In the most common case there is a single delay statement, and this 11337 -- is handled specially. 11338 11339 if Delay_Count > 0 then 11340 11341 -- Generate the required declarations 11342 11343 Delay_Val := 11344 Make_Defining_Identifier (Loc, New_External_Name ('D', 1)); 11345 Delay_Index := 11346 Make_Defining_Identifier (Loc, New_External_Name ('D', 2)); 11347 Delay_Min := 11348 Make_Defining_Identifier (Loc, New_External_Name ('D', 3)); 11349 11350 pragma Assert (Present (Time_Type)); 11351 11352 Append_To (Decls, 11353 Make_Object_Declaration (Loc, 11354 Defining_Identifier => Delay_Val, 11355 Object_Definition => New_Occurrence_Of (Time_Type, Loc))); 11356 11357 Append_To (Decls, 11358 Make_Object_Declaration (Loc, 11359 Defining_Identifier => Delay_Index, 11360 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 11361 Expression => Make_Integer_Literal (Loc, 0))); 11362 11363 Append_To (Decls, 11364 Make_Object_Declaration (Loc, 11365 Defining_Identifier => Delay_Min, 11366 Object_Definition => New_Occurrence_Of (Time_Type, Loc), 11367 Expression => 11368 Unchecked_Convert_To (Time_Type, 11369 Make_Attribute_Reference (Loc, 11370 Prefix => 11371 New_Occurrence_Of (Underlying_Type (Time_Type), Loc), 11372 Attribute_Name => Name_Last)))); 11373 11374 -- Create Duration and Delay_Mode objects used for passing a delay 11375 -- value to RTS 11376 11377 D := Make_Temporary (Loc, 'D'); 11378 M := Make_Temporary (Loc, 'M'); 11379 11380 declare 11381 Discr : Entity_Id; 11382 11383 begin 11384 -- Note that these values are defined in s-osprim.ads and must 11385 -- be kept in sync: 11386 -- 11387 -- Relative : constant := 0; 11388 -- Absolute_Calendar : constant := 1; 11389 -- Absolute_RT : constant := 2; 11390 11391 if Time_Type = Standard_Duration then 11392 Discr := Make_Integer_Literal (Loc, 0); 11393 11394 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11395 Discr := Make_Integer_Literal (Loc, 1); 11396 11397 else 11398 pragma Assert 11399 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11400 Discr := Make_Integer_Literal (Loc, 2); 11401 end if; 11402 11403 Append_To (Decls, 11404 Make_Object_Declaration (Loc, 11405 Defining_Identifier => D, 11406 Object_Definition => 11407 New_Occurrence_Of (Standard_Duration, Loc))); 11408 11409 Append_To (Decls, 11410 Make_Object_Declaration (Loc, 11411 Defining_Identifier => M, 11412 Object_Definition => 11413 New_Occurrence_Of (Standard_Integer, Loc), 11414 Expression => Discr)); 11415 end; 11416 11417 if Check_Guard then 11418 Guard_Open := 11419 Make_Defining_Identifier (Loc, New_External_Name ('G', 1)); 11420 11421 Append_To (Decls, 11422 Make_Object_Declaration (Loc, 11423 Defining_Identifier => Guard_Open, 11424 Object_Definition => 11425 New_Occurrence_Of (Standard_Boolean, Loc), 11426 Expression => 11427 New_Occurrence_Of (Standard_False, Loc))); 11428 end if; 11429 11430 -- Delay_Count is zero, don't need M and D set (suppress warning) 11431 11432 else 11433 M := Empty; 11434 D := Empty; 11435 end if; 11436 11437 if Present (Terminate_Alt) then 11438 11439 -- If the terminate alternative guard is False, use 11440 -- Simple_Mode; otherwise use Terminate_Mode. 11441 11442 if Present (Condition (Terminate_Alt)) then 11443 Select_Mode := Make_If_Expression (Loc, 11444 New_List (Condition (Terminate_Alt), 11445 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc), 11446 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc))); 11447 else 11448 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc); 11449 end if; 11450 11451 elsif Else_Present or Delay_Count > 0 then 11452 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc); 11453 11454 else 11455 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc); 11456 end if; 11457 11458 Select_Call := Make_Select_Call (Select_Mode); 11459 Append (Select_Call, Stats); 11460 11461 -- Now generate code to act on the result. There is an entry 11462 -- in this case for each accept statement with a non-null body, 11463 -- followed by a branch to the statements that follow the Accept. 11464 -- In the absence of delay alternatives, we generate: 11465 11466 -- case X is 11467 -- when No_Rendezvous => -- omitted if simple mode 11468 -- goto Lab0; 11469 11470 -- when 1 => 11471 -- P1n; 11472 -- goto Lab1; 11473 11474 -- when 2 => 11475 -- P2n; 11476 -- goto Lab2; 11477 11478 -- when others => 11479 -- goto Exit; 11480 -- end case; 11481 -- 11482 -- Lab0: Else_Statements; 11483 -- goto exit; 11484 11485 -- Lab1: Trailing_Statements1; 11486 -- goto Exit; 11487 -- 11488 -- Lab2: Trailing_Statements2; 11489 -- goto Exit; 11490 -- ... 11491 -- Exit: 11492 11493 -- Generate label for common exit 11494 11495 End_Lab := Make_And_Declare_Label (Num_Alts + 1); 11496 11497 -- First entry is the default case, when no rendezvous is possible 11498 11499 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)); 11500 11501 if Else_Present then 11502 11503 -- If no rendezvous is possible, the else part is executed 11504 11505 Lab := Make_And_Declare_Label (0); 11506 Alt_Stats := New_List ( 11507 Make_Goto_Statement (Loc, 11508 Name => New_Copy (Identifier (Lab)))); 11509 11510 Append (Lab, Trailing_List); 11511 Append_List (Else_Statements (N), Trailing_List); 11512 Append_To (Trailing_List, 11513 Make_Goto_Statement (Loc, 11514 Name => New_Copy (Identifier (End_Lab)))); 11515 else 11516 Alt_Stats := New_List ( 11517 Make_Goto_Statement (Loc, 11518 Name => New_Copy (Identifier (End_Lab)))); 11519 end if; 11520 11521 Append_To (Alt_List, 11522 Make_Case_Statement_Alternative (Loc, 11523 Discrete_Choices => Choices, 11524 Statements => Alt_Stats)); 11525 11526 -- We make use of the fact that Accept_Index is an integer type, and 11527 -- generate successive literals for entries for each accept. Only those 11528 -- for which there is a body or trailing statements get a case entry. 11529 11530 Alt := First (Select_Alternatives (N)); 11531 Proc := First (Body_List); 11532 while Present (Alt) loop 11533 11534 if Nkind (Alt) = N_Accept_Alternative then 11535 Process_Accept_Alternative (Alt, Index, Proc); 11536 Index := Index + 1; 11537 11538 if Present 11539 (Handled_Statement_Sequence (Accept_Statement (Alt))) 11540 then 11541 Next (Proc); 11542 end if; 11543 11544 elsif Nkind (Alt) = N_Delay_Alternative then 11545 Process_Delay_Alternative (Alt, Delay_Num); 11546 Delay_Num := Delay_Num + 1; 11547 end if; 11548 11549 Next (Alt); 11550 end loop; 11551 11552 -- An others choice is always added to the main case, as well 11553 -- as the delay case (to satisfy the compiler). 11554 11555 Append_To (Alt_List, 11556 Make_Case_Statement_Alternative (Loc, 11557 Discrete_Choices => 11558 New_List (Make_Others_Choice (Loc)), 11559 Statements => 11560 New_List (Make_Goto_Statement (Loc, 11561 Name => New_Copy (Identifier (End_Lab)))))); 11562 11563 Accept_Case := New_List ( 11564 Make_Case_Statement (Loc, 11565 Expression => New_Occurrence_Of (Xnam, Loc), 11566 Alternatives => Alt_List)); 11567 11568 Append_List (Trailing_List, Accept_Case); 11569 Append_List (Body_List, Decls); 11570 11571 -- Construct case statement for trailing statements of delay 11572 -- alternatives, if there are several of them. 11573 11574 if Delay_Count > 1 then 11575 Append_To (Delay_Alt_List, 11576 Make_Case_Statement_Alternative (Loc, 11577 Discrete_Choices => 11578 New_List (Make_Others_Choice (Loc)), 11579 Statements => 11580 New_List (Make_Null_Statement (Loc)))); 11581 11582 Delay_Case := New_List ( 11583 Make_Case_Statement (Loc, 11584 Expression => New_Occurrence_Of (Delay_Index, Loc), 11585 Alternatives => Delay_Alt_List)); 11586 else 11587 Delay_Case := Delay_Alt_List; 11588 end if; 11589 11590 -- If there are no delay alternatives, we append the case statement 11591 -- to the statement list. 11592 11593 if Delay_Count = 0 then 11594 Append_List (Accept_Case, Stats); 11595 11596 -- Delay alternatives present 11597 11598 else 11599 -- If delay alternatives are present we generate: 11600 11601 -- find minimum delay. 11602 -- DX := minimum delay; 11603 -- M := <delay mode>; 11604 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P, 11605 -- DX, MX, X); 11606 -- 11607 -- if X = No_Rendezvous then 11608 -- case statement for delay statements. 11609 -- else 11610 -- case statement for accept alternatives. 11611 -- end if; 11612 11613 declare 11614 Cases : Node_Id; 11615 Stmt : Node_Id; 11616 Parms : List_Id; 11617 Parm : Node_Id; 11618 Conv : Node_Id; 11619 11620 begin 11621 -- The type of the delay expression is known to be legal 11622 11623 if Time_Type = Standard_Duration then 11624 Conv := New_Occurrence_Of (Delay_Min, Loc); 11625 11626 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11627 Conv := Make_Function_Call (Loc, 11628 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 11629 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11630 11631 else 11632 pragma Assert 11633 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11634 11635 Conv := Make_Function_Call (Loc, 11636 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 11637 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11638 end if; 11639 11640 Stmt := Make_Assignment_Statement (Loc, 11641 Name => New_Occurrence_Of (D, Loc), 11642 Expression => Conv); 11643 11644 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) 11645 11646 Parms := Parameter_Associations (Select_Call); 11647 11648 Parm := First (Parms); 11649 while Present (Parm) and then Parm /= Select_Mode loop 11650 Next (Parm); 11651 end loop; 11652 11653 pragma Assert (Present (Parm)); 11654 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc)); 11655 Analyze (Parm); 11656 11657 -- Prepare two new parameters of Duration and Delay_Mode type 11658 -- which represent the value and the mode of the minimum delay. 11659 11660 Next (Parm); 11661 Insert_After (Parm, New_Occurrence_Of (M, Loc)); 11662 Insert_After (Parm, New_Occurrence_Of (D, Loc)); 11663 11664 -- Create a call to RTS 11665 11666 Rewrite (Select_Call, 11667 Make_Procedure_Call_Statement (Loc, 11668 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc), 11669 Parameter_Associations => Parms)); 11670 11671 -- This new call should follow the calculation of the minimum 11672 -- delay. 11673 11674 Insert_List_Before (Select_Call, Delay_List); 11675 11676 if Check_Guard then 11677 Stmt := 11678 Make_Implicit_If_Statement (N, 11679 Condition => New_Occurrence_Of (Guard_Open, Loc), 11680 Then_Statements => New_List ( 11681 New_Copy_Tree (Stmt), 11682 New_Copy_Tree (Select_Call)), 11683 Else_Statements => Accept_Or_Raise); 11684 Rewrite (Select_Call, Stmt); 11685 else 11686 Insert_Before (Select_Call, Stmt); 11687 end if; 11688 11689 Cases := 11690 Make_Implicit_If_Statement (N, 11691 Condition => Make_Op_Eq (Loc, 11692 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 11693 Right_Opnd => 11694 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 11695 11696 Then_Statements => Delay_Case, 11697 Else_Statements => Accept_Case); 11698 11699 Append (Cases, Stats); 11700 end; 11701 end if; 11702 11703 Append (End_Lab, Stats); 11704 11705 -- Replace accept statement with appropriate block 11706 11707 Rewrite (N, 11708 Make_Block_Statement (Loc, 11709 Declarations => Decls, 11710 Handled_Statement_Sequence => 11711 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats))); 11712 Analyze (N); 11713 11714 -- Note: have to worry more about abort deferral in above code ??? 11715 11716 -- Final step is to unstack the Accept_Address entries for all accept 11717 -- statements appearing in accept alternatives in the select statement 11718 11719 Alt := First (Alts); 11720 while Present (Alt) loop 11721 if Nkind (Alt) = N_Accept_Alternative then 11722 Remove_Last_Elmt (Accept_Address 11723 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))); 11724 end if; 11725 11726 Next (Alt); 11727 end loop; 11728 end Expand_N_Selective_Accept; 11729 11730 ------------------------------------------- 11731 -- Expand_N_Single_Protected_Declaration -- 11732 ------------------------------------------- 11733 11734 -- A single protected declaration should never be present after semantic 11735 -- analysis because it is transformed into a protected type declaration 11736 -- and an accompanying anonymous object. This routine ensures that the 11737 -- transformation takes place. 11738 11739 procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is 11740 begin 11741 raise Program_Error; 11742 end Expand_N_Single_Protected_Declaration; 11743 11744 -------------------------------------- 11745 -- Expand_N_Single_Task_Declaration -- 11746 -------------------------------------- 11747 11748 -- A single task declaration should never be present after semantic 11749 -- analysis because it is transformed into a task type declaration and 11750 -- an accompanying anonymous object. This routine ensures that the 11751 -- transformation takes place. 11752 11753 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is 11754 begin 11755 raise Program_Error; 11756 end Expand_N_Single_Task_Declaration; 11757 11758 ------------------------ 11759 -- Expand_N_Task_Body -- 11760 ------------------------ 11761 11762 -- Given a task body 11763 11764 -- task body tname is 11765 -- <declarations> 11766 -- begin 11767 -- <statements> 11768 -- end x; 11769 11770 -- This expansion routine converts it into a procedure and sets the 11771 -- elaboration flag for the procedure to true, to represent the fact 11772 -- that the task body is now elaborated: 11773 11774 -- procedure tnameB (_Task : access tnameV) is 11775 -- discriminal : dtype renames _Task.discriminant; 11776 11777 -- procedure _clean is 11778 -- begin 11779 -- Abort_Defer.all; 11780 -- Complete_Task; 11781 -- Abort_Undefer.all; 11782 -- return; 11783 -- end _clean; 11784 11785 -- begin 11786 -- Abort_Undefer.all; 11787 -- <declarations> 11788 -- System.Task_Stages.Complete_Activation; 11789 -- <statements> 11790 -- at end 11791 -- _clean; 11792 -- end tnameB; 11793 11794 -- tnameE := True; 11795 11796 -- In addition, if the task body is an activator, then a call to activate 11797 -- tasks is added at the start of the statements, before the call to 11798 -- Complete_Activation, and if in addition the task is a master then it 11799 -- must be established as a master. These calls are inserted and analyzed 11800 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is 11801 -- expanded. 11802 11803 -- There is one discriminal declaration line generated for each 11804 -- discriminant that is present to provide an easy reference point for 11805 -- discriminant references inside the body (see Exp_Ch2.Expand_Name). 11806 11807 -- Note on relationship to GNARLI definition. In the GNARLI definition, 11808 -- task body procedures have a profile (Arg : System.Address). That is 11809 -- needed because GNARLI has to use the same access-to-subprogram type 11810 -- for all task types. We depend here on knowing that in GNAT, passing 11811 -- an address argument by value is identical to passing a record value 11812 -- by access (in either case a single pointer is passed), so even though 11813 -- this procedure has the wrong profile. In fact it's all OK, since the 11814 -- callings sequence is identical. 11815 11816 procedure Expand_N_Task_Body (N : Node_Id) is 11817 Loc : constant Source_Ptr := Sloc (N); 11818 Ttyp : constant Entity_Id := Corresponding_Spec (N); 11819 Call : Node_Id; 11820 New_N : Node_Id; 11821 11822 Insert_Nod : Node_Id; 11823 -- Used to determine the proper location of wrapper body insertions 11824 11825 begin 11826 -- if no task body procedure, means we had an error in configurable 11827 -- run-time mode, and there is no point in proceeding further. 11828 11829 if No (Task_Body_Procedure (Ttyp)) then 11830 return; 11831 end if; 11832 11833 -- Add renaming declarations for discriminals and a declaration for the 11834 -- entry family index (if applicable). 11835 11836 Install_Private_Data_Declarations 11837 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N)); 11838 11839 -- Add a call to Abort_Undefer at the very beginning of the task 11840 -- body since this body is called with abort still deferred. 11841 11842 if Abort_Allowed then 11843 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 11844 Insert_Before 11845 (First (Statements (Handled_Statement_Sequence (N))), Call); 11846 Analyze (Call); 11847 end if; 11848 11849 -- The statement part has already been protected with an at_end and 11850 -- cleanup actions. The call to Complete_Activation must be placed 11851 -- at the head of the sequence of statements of that block. The 11852 -- declarations have been merged in this sequence of statements but 11853 -- the first real statement is accessible from the First_Real_Statement 11854 -- field (which was set for exactly this purpose). 11855 11856 if Restricted_Profile then 11857 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); 11858 else 11859 Call := Build_Runtime_Call (Loc, RE_Complete_Activation); 11860 end if; 11861 11862 Insert_Before 11863 (First_Real_Statement (Handled_Statement_Sequence (N)), Call); 11864 Analyze (Call); 11865 11866 New_N := 11867 Make_Subprogram_Body (Loc, 11868 Specification => Build_Task_Proc_Specification (Ttyp), 11869 Declarations => Declarations (N), 11870 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 11871 Set_Is_Task_Body_Procedure (New_N); 11872 11873 -- If the task contains generic instantiations, cleanup actions are 11874 -- delayed until after instantiation. Transfer the activation chain to 11875 -- the subprogram, to insure that the activation call is properly 11876 -- generated. It the task body contains inner tasks, indicate that the 11877 -- subprogram is a task master. 11878 11879 if Delay_Cleanups (Ttyp) then 11880 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); 11881 Set_Is_Task_Master (New_N, Is_Task_Master (N)); 11882 end if; 11883 11884 Rewrite (N, New_N); 11885 Analyze (N); 11886 11887 -- Set elaboration flag immediately after task body. If the body is a 11888 -- subunit, the flag is set in the declarative part containing the stub. 11889 11890 if Nkind (Parent (N)) /= N_Subunit then 11891 Insert_After (N, 11892 Make_Assignment_Statement (Loc, 11893 Name => 11894 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), 11895 Expression => New_Occurrence_Of (Standard_True, Loc))); 11896 end if; 11897 11898 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after 11899 -- the task body. At this point all wrapper specs have been created, 11900 -- frozen and included in the dispatch table for the task type. 11901 11902 if Ada_Version >= Ada_2005 then 11903 if Nkind (Parent (N)) = N_Subunit then 11904 Insert_Nod := Corresponding_Stub (Parent (N)); 11905 else 11906 Insert_Nod := N; 11907 end if; 11908 11909 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod); 11910 end if; 11911 end Expand_N_Task_Body; 11912 11913 ------------------------------------ 11914 -- Expand_N_Task_Type_Declaration -- 11915 ------------------------------------ 11916 11917 -- We have several things to do. First we must create a Boolean flag used 11918 -- to mark if the body is elaborated yet. This variable gets set to True 11919 -- when the body of the task is elaborated (we can't rely on the normal 11920 -- ABE mechanism for the task body, since we need to pass an access to 11921 -- this elaboration boolean to the runtime routines). 11922 11923 -- taskE : aliased Boolean := False; 11924 11925 -- Next a variable is declared to hold the task stack size (either the 11926 -- default : Unspecified_Size, or a value that is set by a pragma 11927 -- Storage_Size). If the value of the pragma Storage_Size is static, then 11928 -- the variable is initialized with this value: 11929 11930 -- taskZ : Size_Type := Unspecified_Size; 11931 -- or 11932 -- taskZ : Size_Type := Size_Type (size_expression); 11933 11934 -- Note: No variable is needed to hold the task relative deadline since 11935 -- its value would never be static because the parameter is of a private 11936 -- type (Ada.Real_Time.Time_Span). 11937 11938 -- Next we create a corresponding record type declaration used to represent 11939 -- values of this task. The general form of this type declaration is 11940 11941 -- type taskV (discriminants) is record 11942 -- _Task_Id : Task_Id; 11943 -- entry_family : array (bounds) of Void; 11944 -- _Priority : Integer := priority_expression; 11945 -- _Size : Size_Type := size_expression; 11946 -- _Secondary_Stack_Size : Size_Type := size_expression; 11947 -- _Task_Info : Task_Info_Type := task_info_expression; 11948 -- _CPU : Integer := cpu_range_expression; 11949 -- _Relative_Deadline : Time_Span := time_span_expression; 11950 -- _Domain : Dispatching_Domain := dd_expression; 11951 -- end record; 11952 11953 -- The discriminants are present only if the corresponding task type has 11954 -- discriminants, and they exactly mirror the task type discriminants. 11955 11956 -- The Id field is always present. It contains the Task_Id value, as set by 11957 -- the call to Create_Task. Note that although the task is limited, the 11958 -- task value record type is not limited, so there is no problem in passing 11959 -- this field as an out parameter to Create_Task. 11960 11961 -- One entry_family component is present for each entry family in the task 11962 -- definition. The bounds correspond to the bounds of the entry family 11963 -- (which may depend on discriminants). The element type is void, since we 11964 -- only need the bounds information for determining the entry index. Note 11965 -- that the use of an anonymous array would normally be illegal in this 11966 -- context, but this is a parser check, and the semantics is quite prepared 11967 -- to handle such a case. 11968 11969 -- The _Size field is present only if a Storage_Size pragma appears in the 11970 -- task definition. The expression captures the argument that was present 11971 -- in the pragma, and is used to override the task stack size otherwise 11972 -- associated with the task type. 11973 11974 -- The _Secondary_Stack_Size field is present only the task entity has a 11975 -- Secondary_Stack_Size rep item. It will be filled at the freeze point, 11976 -- when the record init proc is built, to capture the expression of the 11977 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot 11978 -- be filled here since aspect evaluations are delayed till the freeze 11979 -- point. 11980 11981 -- The _Priority field is present only if the task entity has a Priority or 11982 -- Interrupt_Priority rep item (pragma, aspect specification or attribute 11983 -- definition clause). It will be filled at the freeze point, when the 11984 -- record init proc is built, to capture the expression of the rep item 11985 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11986 -- here since aspect evaluations are delayed till the freeze point. 11987 11988 -- The _Task_Info field is present only if a Task_Info pragma appears in 11989 -- the task definition. The expression captures the argument that was 11990 -- present in the pragma, and is used to provide the Task_Image parameter 11991 -- to the call to Create_Task. 11992 11993 -- The _CPU field is present only if the task entity has a CPU rep item 11994 -- (pragma, aspect specification or attribute definition clause). It will 11995 -- be filled at the freeze point, when the record init proc is built, to 11996 -- capture the expression of the rep item (see Build_Record_Init_Proc in 11997 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations 11998 -- are delayed till the freeze point. 11999 12000 -- The _Relative_Deadline field is present only if a Relative_Deadline 12001 -- pragma appears in the task definition. The expression captures the 12002 -- argument that was present in the pragma, and is used to provide the 12003 -- Relative_Deadline parameter to the call to Create_Task. 12004 12005 -- The _Domain field is present only if the task entity has a 12006 -- Dispatching_Domain rep item (pragma, aspect specification or attribute 12007 -- definition clause). It will be filled at the freeze point, when the 12008 -- record init proc is built, to capture the expression of the rep item 12009 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 12010 -- here since aspect evaluations are delayed till the freeze point. 12011 12012 -- When a task is declared, an instance of the task value record is 12013 -- created. The elaboration of this declaration creates the correct bounds 12014 -- for the entry families, and also evaluates the size, priority, and 12015 -- task_Info expressions if needed. The initialization routine for the task 12016 -- type itself then calls Create_Task with appropriate parameters to 12017 -- initialize the value of the Task_Id field. 12018 12019 -- Note: the address of this record is passed as the "Discriminants" 12020 -- parameter for Create_Task. Since Create_Task merely passes this onto the 12021 -- body procedure, it does not matter that it does not quite match the 12022 -- GNARLI model of what is being passed (the record contains more than just 12023 -- the discriminants, but the discriminants can be found from the record 12024 -- value). 12025 12026 -- The Entity_Id for this created record type is placed in the 12027 -- Corresponding_Record_Type field of the associated task type entity. 12028 12029 -- Next we create a procedure specification for the task body procedure: 12030 12031 -- procedure taskB (_Task : access taskV); 12032 12033 -- Note that this must come after the record type declaration, since 12034 -- the spec refers to this type. It turns out that the initialization 12035 -- procedure for the value type references the task body spec, but that's 12036 -- fine, since it won't be generated till the freeze point for the type, 12037 -- which is certainly after the task body spec declaration. 12038 12039 -- Finally, we set the task index value field of the entry attribute in 12040 -- the case of a simple entry. 12041 12042 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is 12043 Loc : constant Source_Ptr := Sloc (N); 12044 TaskId : constant Entity_Id := Defining_Identifier (N); 12045 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); 12046 Tasknm : constant Name_Id := Chars (Tasktyp); 12047 Taskdef : constant Node_Id := Task_Definition (N); 12048 12049 Body_Decl : Node_Id; 12050 Cdecls : List_Id; 12051 Decl_Stack : Node_Id; 12052 Decl_SS : Node_Id; 12053 Elab_Decl : Node_Id; 12054 Ent_Stack : Entity_Id; 12055 Proc_Spec : Node_Id; 12056 Rec_Decl : Node_Id; 12057 Rec_Ent : Entity_Id; 12058 Size_Decl : Entity_Id; 12059 Task_Size : Node_Id; 12060 12061 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id; 12062 -- Searches the task definition T for the first occurrence of the pragma 12063 -- Relative Deadline. The caller has ensured that the pragma is present 12064 -- in the task definition. Note that this routine cannot be implemented 12065 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are 12066 -- not chained because their expansion into a procedure call statement 12067 -- would cause a break in the chain. 12068 12069 ---------------------------------- 12070 -- Get_Relative_Deadline_Pragma -- 12071 ---------------------------------- 12072 12073 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is 12074 N : Node_Id; 12075 12076 begin 12077 N := First (Visible_Declarations (T)); 12078 while Present (N) loop 12079 if Nkind (N) = N_Pragma 12080 and then Pragma_Name (N) = Name_Relative_Deadline 12081 then 12082 return N; 12083 end if; 12084 12085 Next (N); 12086 end loop; 12087 12088 N := First (Private_Declarations (T)); 12089 while Present (N) loop 12090 if Nkind (N) = N_Pragma 12091 and then Pragma_Name (N) = Name_Relative_Deadline 12092 then 12093 return N; 12094 end if; 12095 12096 Next (N); 12097 end loop; 12098 12099 raise Program_Error; 12100 end Get_Relative_Deadline_Pragma; 12101 12102 -- Start of processing for Expand_N_Task_Type_Declaration 12103 12104 begin 12105 -- If already expanded, nothing to do 12106 12107 if Present (Corresponding_Record_Type (Tasktyp)) then 12108 return; 12109 end if; 12110 12111 -- Here we will do the expansion 12112 12113 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); 12114 12115 Rec_Ent := Defining_Identifier (Rec_Decl); 12116 Cdecls := Component_Items (Component_List 12117 (Type_Definition (Rec_Decl))); 12118 12119 Qualify_Entity_Names (N); 12120 12121 -- First create the elaboration variable 12122 12123 Elab_Decl := 12124 Make_Object_Declaration (Loc, 12125 Defining_Identifier => 12126 Make_Defining_Identifier (Sloc (Tasktyp), 12127 Chars => New_External_Name (Tasknm, 'E')), 12128 Aliased_Present => True, 12129 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 12130 Expression => New_Occurrence_Of (Standard_False, Loc)); 12131 12132 Insert_After (N, Elab_Decl); 12133 12134 -- Next create the declaration of the size variable (tasknmZ) 12135 12136 Set_Storage_Size_Variable (Tasktyp, 12137 Make_Defining_Identifier (Sloc (Tasktyp), 12138 Chars => New_External_Name (Tasknm, 'Z'))); 12139 12140 if Present (Taskdef) 12141 and then Has_Storage_Size_Pragma (Taskdef) 12142 and then 12143 Is_OK_Static_Expression 12144 (Expression 12145 (First (Pragma_Argument_Associations 12146 (Get_Rep_Pragma (TaskId, Name_Storage_Size))))) 12147 then 12148 Size_Decl := 12149 Make_Object_Declaration (Loc, 12150 Defining_Identifier => Storage_Size_Variable (Tasktyp), 12151 Object_Definition => 12152 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 12153 Expression => 12154 Convert_To (RTE (RE_Size_Type), 12155 Relocate_Node 12156 (Expression (First (Pragma_Argument_Associations 12157 (Get_Rep_Pragma 12158 (TaskId, Name_Storage_Size))))))); 12159 12160 else 12161 Size_Decl := 12162 Make_Object_Declaration (Loc, 12163 Defining_Identifier => Storage_Size_Variable (Tasktyp), 12164 Object_Definition => 12165 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 12166 Expression => 12167 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 12168 end if; 12169 12170 Insert_After (Elab_Decl, Size_Decl); 12171 12172 -- Next build the rest of the corresponding record declaration. This is 12173 -- done last, since the corresponding record initialization procedure 12174 -- will reference the previously created entities. 12175 12176 -- Fill in the component declarations -- first the _Task_Id field 12177 12178 Append_To (Cdecls, 12179 Make_Component_Declaration (Loc, 12180 Defining_Identifier => 12181 Make_Defining_Identifier (Loc, Name_uTask_Id), 12182 Component_Definition => 12183 Make_Component_Definition (Loc, 12184 Aliased_Present => False, 12185 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id), 12186 Loc)))); 12187 12188 -- Declare static ATCB (that is, created by the expander) if we are 12189 -- using the Restricted run time. 12190 12191 if Restricted_Profile then 12192 Append_To (Cdecls, 12193 Make_Component_Declaration (Loc, 12194 Defining_Identifier => 12195 Make_Defining_Identifier (Loc, Name_uATCB), 12196 12197 Component_Definition => 12198 Make_Component_Definition (Loc, 12199 Aliased_Present => True, 12200 Subtype_Indication => Make_Subtype_Indication (Loc, 12201 Subtype_Mark => 12202 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc), 12203 12204 Constraint => 12205 Make_Index_Or_Discriminant_Constraint (Loc, 12206 Constraints => 12207 New_List (Make_Integer_Literal (Loc, 0))))))); 12208 12209 end if; 12210 12211 -- Declare static stack (that is, created by the expander) if we are 12212 -- using the Restricted run time on a bare board configuration. 12213 12214 if Restricted_Profile and then Preallocated_Stacks_On_Target then 12215 12216 -- First we need to extract the appropriate stack size 12217 12218 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack); 12219 12220 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 12221 declare 12222 Expr_N : constant Node_Id := 12223 Expression (First ( 12224 Pragma_Argument_Associations ( 12225 Get_Rep_Pragma (TaskId, Name_Storage_Size)))); 12226 Etyp : constant Entity_Id := Etype (Expr_N); 12227 P : constant Node_Id := Parent (Expr_N); 12228 12229 begin 12230 -- The stack is defined inside the corresponding record. 12231 -- Therefore if the size of the stack is set by means of 12232 -- a discriminant, we must reference the discriminant of the 12233 -- corresponding record type. 12234 12235 if Nkind (Expr_N) in N_Has_Entity 12236 and then Present (Discriminal_Link (Entity (Expr_N))) 12237 then 12238 Task_Size := 12239 New_Occurrence_Of 12240 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))), 12241 Loc); 12242 Set_Parent (Task_Size, P); 12243 Set_Etype (Task_Size, Etyp); 12244 Set_Analyzed (Task_Size); 12245 12246 else 12247 Task_Size := New_Copy_Tree (Expr_N); 12248 end if; 12249 end; 12250 12251 else 12252 Task_Size := 12253 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc); 12254 end if; 12255 12256 Decl_Stack := Make_Component_Declaration (Loc, 12257 Defining_Identifier => Ent_Stack, 12258 12259 Component_Definition => 12260 Make_Component_Definition (Loc, 12261 Aliased_Present => True, 12262 Subtype_Indication => Make_Subtype_Indication (Loc, 12263 Subtype_Mark => 12264 New_Occurrence_Of (RTE (RE_Storage_Array), Loc), 12265 12266 Constraint => 12267 Make_Index_Or_Discriminant_Constraint (Loc, 12268 Constraints => New_List (Make_Range (Loc, 12269 Low_Bound => Make_Integer_Literal (Loc, 1), 12270 High_Bound => Convert_To (RTE (RE_Storage_Offset), 12271 Task_Size))))))); 12272 12273 Append_To (Cdecls, Decl_Stack); 12274 12275 -- The appropriate alignment for the stack is ensured by the run-time 12276 -- code in charge of task creation. 12277 12278 end if; 12279 12280 -- Declare a static secondary stack if the conditions for a statically 12281 -- generated stack are met. 12282 12283 if Create_Secondary_Stack_For_Task (TaskId) then 12284 declare 12285 Size_Expr : constant Node_Id := 12286 Expression (First ( 12287 Pragma_Argument_Associations ( 12288 Get_Rep_Pragma (TaskId, 12289 Name_Secondary_Stack_Size)))); 12290 12291 Stack_Size : Node_Id; 12292 12293 begin 12294 -- The secondary stack is defined inside the corresponding 12295 -- record. Therefore if the size of the stack is set by means 12296 -- of a discriminant, we must reference the discriminant of the 12297 -- corresponding record type. 12298 12299 if Nkind (Size_Expr) in N_Has_Entity 12300 and then Present (Discriminal_Link (Entity (Size_Expr))) 12301 then 12302 Stack_Size := 12303 New_Occurrence_Of 12304 (CR_Discriminant (Discriminal_Link (Entity (Size_Expr))), 12305 Loc); 12306 Set_Parent (Stack_Size, Parent (Size_Expr)); 12307 Set_Etype (Stack_Size, Etype (Size_Expr)); 12308 Set_Analyzed (Stack_Size); 12309 12310 else 12311 Stack_Size := New_Copy_Tree (Size_Expr); 12312 end if; 12313 12314 -- Create the secondary stack for the task 12315 12316 Decl_SS := 12317 Make_Component_Declaration (Loc, 12318 Defining_Identifier => 12319 Make_Defining_Identifier (Loc, Name_uSecondary_Stack), 12320 Component_Definition => 12321 Make_Component_Definition (Loc, 12322 Aliased_Present => True, 12323 Subtype_Indication => 12324 Make_Subtype_Indication (Loc, 12325 Subtype_Mark => 12326 New_Occurrence_Of (RTE (RE_SS_Stack), Loc), 12327 Constraint => 12328 Make_Index_Or_Discriminant_Constraint (Loc, 12329 Constraints => New_List ( 12330 Convert_To (RTE (RE_Size_Type), 12331 Stack_Size)))))); 12332 12333 Append_To (Cdecls, Decl_SS); 12334 end; 12335 end if; 12336 12337 -- Add components for entry families 12338 12339 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); 12340 12341 -- Add the _Priority component if a Interrupt_Priority or Priority rep 12342 -- item is present. 12343 12344 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then 12345 Append_To (Cdecls, 12346 Make_Component_Declaration (Loc, 12347 Defining_Identifier => 12348 Make_Defining_Identifier (Loc, Name_uPriority), 12349 Component_Definition => 12350 Make_Component_Definition (Loc, 12351 Aliased_Present => False, 12352 Subtype_Indication => 12353 New_Occurrence_Of (Standard_Integer, Loc)))); 12354 end if; 12355 12356 -- Add the _Size component if a Storage_Size pragma is present 12357 12358 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 12359 Append_To (Cdecls, 12360 Make_Component_Declaration (Loc, 12361 Defining_Identifier => 12362 Make_Defining_Identifier (Loc, Name_uSize), 12363 12364 Component_Definition => 12365 Make_Component_Definition (Loc, 12366 Aliased_Present => False, 12367 Subtype_Indication => 12368 New_Occurrence_Of (RTE (RE_Size_Type), Loc)), 12369 12370 Expression => 12371 Convert_To (RTE (RE_Size_Type), 12372 New_Copy_Tree ( 12373 Expression (First ( 12374 Pragma_Argument_Associations ( 12375 Get_Rep_Pragma (TaskId, Name_Storage_Size)))))))); 12376 end if; 12377 12378 -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size 12379 -- pragma is present. 12380 12381 if Has_Rep_Pragma 12382 (TaskId, Name_Secondary_Stack_Size, Check_Parents => False) 12383 then 12384 Append_To (Cdecls, 12385 Make_Component_Declaration (Loc, 12386 Defining_Identifier => 12387 Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size), 12388 12389 Component_Definition => 12390 Make_Component_Definition (Loc, 12391 Aliased_Present => False, 12392 Subtype_Indication => 12393 New_Occurrence_Of (RTE (RE_Size_Type), Loc)))); 12394 end if; 12395 12396 -- Add the _Task_Info component if a Task_Info pragma is present 12397 12398 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then 12399 Append_To (Cdecls, 12400 Make_Component_Declaration (Loc, 12401 Defining_Identifier => 12402 Make_Defining_Identifier (Loc, Name_uTask_Info), 12403 12404 Component_Definition => 12405 Make_Component_Definition (Loc, 12406 Aliased_Present => False, 12407 Subtype_Indication => 12408 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)), 12409 12410 Expression => New_Copy ( 12411 Expression (First ( 12412 Pragma_Argument_Associations ( 12413 Get_Rep_Pragma 12414 (TaskId, Name_Task_Info, Check_Parents => False))))))); 12415 end if; 12416 12417 -- Add the _CPU component if a CPU rep item is present 12418 12419 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then 12420 Append_To (Cdecls, 12421 Make_Component_Declaration (Loc, 12422 Defining_Identifier => 12423 Make_Defining_Identifier (Loc, Name_uCPU), 12424 12425 Component_Definition => 12426 Make_Component_Definition (Loc, 12427 Aliased_Present => False, 12428 Subtype_Indication => 12429 New_Occurrence_Of (RTE (RE_CPU_Range), Loc)))); 12430 end if; 12431 12432 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is 12433 -- present. If we are using a restricted run time this component will 12434 -- not be added (deadlines are not allowed by the Ravenscar profile), 12435 -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF 12436 -- profile). 12437 12438 if (not Restricted_Profile or else Task_Dispatching_Policy = 'E') 12439 and then Present (Taskdef) 12440 and then Has_Relative_Deadline_Pragma (Taskdef) 12441 then 12442 Append_To (Cdecls, 12443 Make_Component_Declaration (Loc, 12444 Defining_Identifier => 12445 Make_Defining_Identifier (Loc, Name_uRelative_Deadline), 12446 12447 Component_Definition => 12448 Make_Component_Definition (Loc, 12449 Aliased_Present => False, 12450 Subtype_Indication => 12451 New_Occurrence_Of (RTE (RE_Time_Span), Loc)), 12452 12453 Expression => 12454 Convert_To (RTE (RE_Time_Span), 12455 New_Copy_Tree ( 12456 Expression (First ( 12457 Pragma_Argument_Associations ( 12458 Get_Relative_Deadline_Pragma (Taskdef)))))))); 12459 end if; 12460 12461 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep 12462 -- item is present. If we are using a restricted run time this component 12463 -- will not be added (dispatching domains are not allowed by the 12464 -- Ravenscar profile). 12465 12466 if not Restricted_Profile 12467 and then 12468 Has_Rep_Item 12469 (TaskId, Name_Dispatching_Domain, Check_Parents => False) 12470 then 12471 Append_To (Cdecls, 12472 Make_Component_Declaration (Loc, 12473 Defining_Identifier => 12474 Make_Defining_Identifier (Loc, Name_uDispatching_Domain), 12475 12476 Component_Definition => 12477 Make_Component_Definition (Loc, 12478 Aliased_Present => False, 12479 Subtype_Indication => 12480 New_Occurrence_Of 12481 (RTE (RE_Dispatching_Domain_Access), Loc)))); 12482 end if; 12483 12484 Insert_After (Size_Decl, Rec_Decl); 12485 12486 -- Analyze the record declaration immediately after construction, 12487 -- because the initialization procedure is needed for single task 12488 -- declarations before the next entity is analyzed. 12489 12490 Analyze (Rec_Decl); 12491 12492 -- Create the declaration of the task body procedure 12493 12494 Proc_Spec := Build_Task_Proc_Specification (Tasktyp); 12495 Body_Decl := 12496 Make_Subprogram_Declaration (Loc, 12497 Specification => Proc_Spec); 12498 Set_Is_Task_Body_Procedure (Body_Decl); 12499 12500 Insert_After (Rec_Decl, Body_Decl); 12501 12502 -- The subprogram does not comes from source, so we have to indicate the 12503 -- need for debugging information explicitly. 12504 12505 if Comes_From_Source (Original_Node (N)) then 12506 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec)); 12507 end if; 12508 12509 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before 12510 -- the corresponding record has been frozen. 12511 12512 if Ada_Version >= Ada_2005 then 12513 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl); 12514 end if; 12515 12516 -- Ada 2005 (AI-345): We must defer freezing to allow further 12517 -- declaration of primitive subprograms covering task interfaces 12518 12519 if Ada_Version <= Ada_95 then 12520 12521 -- Now we can freeze the corresponding record. This needs manually 12522 -- freezing, since it is really part of the task type, and the task 12523 -- type is frozen at this stage. We of course need the initialization 12524 -- procedure for this corresponding record type and we won't get it 12525 -- in time if we don't freeze now. 12526 12527 declare 12528 L : constant List_Id := Freeze_Entity (Rec_Ent, N); 12529 begin 12530 if Is_Non_Empty_List (L) then 12531 Insert_List_After (Body_Decl, L); 12532 end if; 12533 end; 12534 end if; 12535 12536 -- Complete the expansion of access types to the current task type, if 12537 -- any were declared. 12538 12539 Expand_Previous_Access_Type (Tasktyp); 12540 12541 -- Create wrappers for entries that have contract cases, preconditions 12542 -- and postconditions. 12543 12544 declare 12545 Ent : Entity_Id; 12546 12547 begin 12548 Ent := First_Entity (Tasktyp); 12549 while Present (Ent) loop 12550 if Ekind (Ent) in E_Entry | E_Entry_Family then 12551 Build_Contract_Wrapper (Ent, N); 12552 end if; 12553 12554 Next_Entity (Ent); 12555 end loop; 12556 end; 12557 end Expand_N_Task_Type_Declaration; 12558 12559 ------------------------------- 12560 -- Expand_N_Timed_Entry_Call -- 12561 ------------------------------- 12562 12563 -- A timed entry call in normal case is not implemented using ATC mechanism 12564 -- anymore for efficiency reason. 12565 12566 -- select 12567 -- T.E; 12568 -- S1; 12569 -- or 12570 -- delay D; 12571 -- S2; 12572 -- end select; 12573 12574 -- is expanded as follows: 12575 12576 -- 1) When T.E is a task entry_call; 12577 12578 -- declare 12579 -- B : Boolean; 12580 -- X : Task_Entry_Index := <entry index>; 12581 -- DX : Duration := To_Duration (D); 12582 -- M : Delay_Mode := <discriminant>; 12583 -- P : parms := (parm, parm, parm); 12584 12585 -- begin 12586 -- Timed_Protected_Entry_Call 12587 -- (<acceptor-task>, X, P'Address, DX, M, B); 12588 -- if B then 12589 -- S1; 12590 -- else 12591 -- S2; 12592 -- end if; 12593 -- end; 12594 12595 -- 2) When T.E is a protected entry_call; 12596 12597 -- declare 12598 -- B : Boolean; 12599 -- X : Protected_Entry_Index := <entry index>; 12600 -- DX : Duration := To_Duration (D); 12601 -- M : Delay_Mode := <discriminant>; 12602 -- P : parms := (parm, parm, parm); 12603 12604 -- begin 12605 -- Timed_Protected_Entry_Call 12606 -- (<object>'unchecked_access, X, P'Address, DX, M, B); 12607 -- if B then 12608 -- S1; 12609 -- else 12610 -- S2; 12611 -- end if; 12612 -- end; 12613 12614 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there 12615 -- is no delay and the triggering statements are executed. We first 12616 -- determine the kind of the triggering call and then execute a 12617 -- synchronized operation or a direct call. 12618 12619 -- declare 12620 -- B : Boolean := False; 12621 -- C : Ada.Tags.Prim_Op_Kind; 12622 -- DX : Duration := To_Duration (D) 12623 -- K : Ada.Tags.Tagged_Kind := 12624 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 12625 -- M : Integer :=...; 12626 -- P : Parameters := (Param1 .. ParamN); 12627 -- S : Integer; 12628 12629 -- begin 12630 -- if K = Ada.Tags.TK_Limited_Tagged 12631 -- or else K = Ada.Tags.TK_Tagged 12632 -- then 12633 -- <dispatching-call>; 12634 -- B := True; 12635 12636 -- else 12637 -- S := 12638 -- Ada.Tags.Get_Offset_Index 12639 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 12640 12641 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B); 12642 12643 -- if C = POK_Protected_Entry 12644 -- or else C = POK_Task_Entry 12645 -- then 12646 -- Param1 := P.Param1; 12647 -- ... 12648 -- ParamN := P.ParamN; 12649 -- end if; 12650 12651 -- if B then 12652 -- if C = POK_Procedure 12653 -- or else C = POK_Protected_Procedure 12654 -- or else C = POK_Task_Procedure 12655 -- then 12656 -- <dispatching-call>; 12657 -- end if; 12658 -- end if; 12659 -- end if; 12660 12661 -- if B then 12662 -- <triggering-statements> 12663 -- else 12664 -- <timed-statements> 12665 -- end if; 12666 -- end; 12667 12668 -- The triggering statement and the sequence of timed statements have not 12669 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain 12670 -- global references if within an instantiation. 12671 12672 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is 12673 Actuals : List_Id; 12674 Blk_Typ : Entity_Id; 12675 Call : Node_Id; 12676 Call_Ent : Entity_Id; 12677 Conc_Typ_Stmts : List_Id; 12678 Concval : Node_Id := Empty; -- init to avoid warning 12679 D_Alt : constant Node_Id := Delay_Alternative (N); 12680 D_Conv : Node_Id; 12681 D_Disc : Node_Id; 12682 D_Stat : Node_Id := Delay_Statement (D_Alt); 12683 D_Stats : List_Id; 12684 D_Type : Entity_Id; 12685 Decls : List_Id; 12686 Dummy : Node_Id; 12687 E_Alt : constant Node_Id := Entry_Call_Alternative (N); 12688 E_Call : Node_Id := Entry_Call_Statement (E_Alt); 12689 E_Stats : List_Id; 12690 Ename : Node_Id; 12691 Formals : List_Id; 12692 Index : Node_Id; 12693 Is_Disp_Select : Boolean; 12694 Lim_Typ_Stmts : List_Id; 12695 Loc : constant Source_Ptr := Sloc (D_Stat); 12696 N_Stats : List_Id; 12697 Obj : Entity_Id; 12698 Param : Node_Id; 12699 Params : List_Id; 12700 Stmt : Node_Id; 12701 Stmts : List_Id; 12702 Unpack : List_Id; 12703 12704 B : Entity_Id; -- Call status flag 12705 C : Entity_Id; -- Call kind 12706 D : Entity_Id; -- Delay 12707 K : Entity_Id; -- Tagged kind 12708 M : Entity_Id; -- Delay mode 12709 P : Entity_Id; -- Parameter block 12710 S : Entity_Id; -- Primitive operation slot 12711 12712 -- Start of processing for Expand_N_Timed_Entry_Call 12713 12714 begin 12715 -- Under the Ravenscar profile, timed entry calls are excluded. An error 12716 -- was already reported on spec, so do not attempt to expand the call. 12717 12718 if Restriction_Active (No_Select_Statements) then 12719 return; 12720 end if; 12721 12722 Process_Statements_For_Controlled_Objects (E_Alt); 12723 Process_Statements_For_Controlled_Objects (D_Alt); 12724 12725 Ensure_Statement_Present (Sloc (D_Stat), D_Alt); 12726 12727 -- Retrieve E_Stats and D_Stats now because the finalization machinery 12728 -- may wrap them in blocks. 12729 12730 E_Stats := Statements (E_Alt); 12731 D_Stats := Statements (D_Alt); 12732 12733 -- The arguments in the call may require dynamic allocation, and the 12734 -- call statement may have been transformed into a block. The block 12735 -- may contain additional declarations for internal entities, and the 12736 -- original call is found by sequential search. 12737 12738 if Nkind (E_Call) = N_Block_Statement then 12739 E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); 12740 while Nkind (E_Call) not in 12741 N_Procedure_Call_Statement | N_Entry_Call_Statement 12742 loop 12743 Next (E_Call); 12744 end loop; 12745 end if; 12746 12747 Is_Disp_Select := 12748 Ada_Version >= Ada_2005 12749 and then Nkind (E_Call) = N_Procedure_Call_Statement; 12750 12751 if Is_Disp_Select then 12752 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals); 12753 Decls := New_List; 12754 12755 Stmts := New_List; 12756 12757 -- Generate: 12758 -- B : Boolean := False; 12759 12760 B := Build_B (Loc, Decls); 12761 12762 -- Generate: 12763 -- C : Ada.Tags.Prim_Op_Kind; 12764 12765 C := Build_C (Loc, Decls); 12766 12767 -- Because the analysis of all statements was disabled, manually 12768 -- analyze the delay statement. 12769 12770 Analyze (D_Stat); 12771 D_Stat := Original_Node (D_Stat); 12772 12773 else 12774 -- Build an entry call using Simple_Entry_Call 12775 12776 Extract_Entry (E_Call, Concval, Ename, Index); 12777 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); 12778 12779 Decls := Declarations (E_Call); 12780 Stmts := Statements (Handled_Statement_Sequence (E_Call)); 12781 12782 if No (Decls) then 12783 Decls := New_List; 12784 end if; 12785 12786 -- Generate: 12787 -- B : Boolean; 12788 12789 B := Make_Defining_Identifier (Loc, Name_uB); 12790 12791 Prepend_To (Decls, 12792 Make_Object_Declaration (Loc, 12793 Defining_Identifier => B, 12794 Object_Definition => 12795 New_Occurrence_Of (Standard_Boolean, Loc))); 12796 end if; 12797 12798 -- Duration and mode processing 12799 12800 D_Type := Base_Type (Etype (Expression (D_Stat))); 12801 12802 -- Use the type of the delay expression (Calendar or Real_Time) to 12803 -- generate the appropriate conversion. 12804 12805 if Nkind (D_Stat) = N_Delay_Relative_Statement then 12806 D_Disc := Make_Integer_Literal (Loc, 0); 12807 D_Conv := Relocate_Node (Expression (D_Stat)); 12808 12809 elsif Is_RTE (D_Type, RO_CA_Time) then 12810 D_Disc := Make_Integer_Literal (Loc, 1); 12811 D_Conv := 12812 Make_Function_Call (Loc, 12813 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 12814 Parameter_Associations => 12815 New_List (New_Copy (Expression (D_Stat)))); 12816 12817 else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); 12818 D_Disc := Make_Integer_Literal (Loc, 2); 12819 D_Conv := 12820 Make_Function_Call (Loc, 12821 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 12822 Parameter_Associations => 12823 New_List (New_Copy (Expression (D_Stat)))); 12824 end if; 12825 12826 D := Make_Temporary (Loc, 'D'); 12827 12828 -- Generate: 12829 -- D : Duration; 12830 12831 Append_To (Decls, 12832 Make_Object_Declaration (Loc, 12833 Defining_Identifier => D, 12834 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc))); 12835 12836 M := Make_Temporary (Loc, 'M'); 12837 12838 -- Generate: 12839 -- M : Integer := (0 | 1 | 2); 12840 12841 Append_To (Decls, 12842 Make_Object_Declaration (Loc, 12843 Defining_Identifier => M, 12844 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 12845 Expression => D_Disc)); 12846 12847 -- Parameter block processing 12848 12849 -- Manually create the parameter block for dispatching calls. In the 12850 -- case of entries, the block has already been created during the call 12851 -- to Build_Simple_Entry_Call. 12852 12853 if Is_Disp_Select then 12854 12855 -- Compute the delay at this stage because the evaluation of its 12856 -- expression must not occur earlier (see ACVC C97302A). 12857 12858 Append_To (Stmts, 12859 Make_Assignment_Statement (Loc, 12860 Name => New_Occurrence_Of (D, Loc), 12861 Expression => D_Conv)); 12862 12863 -- Tagged kind processing, generate: 12864 -- K : Ada.Tags.Tagged_Kind := 12865 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>)); 12866 12867 K := Build_K (Loc, Decls, Obj); 12868 12869 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 12870 P := 12871 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 12872 12873 -- Dispatch table slot processing, generate: 12874 -- S : Integer; 12875 12876 S := Build_S (Loc, Decls); 12877 12878 -- Generate: 12879 -- S := Ada.Tags.Get_Offset_Index 12880 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 12881 12882 Conc_Typ_Stmts := 12883 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 12884 12885 -- Generate: 12886 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B); 12887 12888 -- where Obj is the controlling formal parameter, S is the dispatch 12889 -- table slot number of the dispatching operation, P is the wrapped 12890 -- parameter block, D is the duration, M is the duration mode, C is 12891 -- the call kind and B is the call status. 12892 12893 Params := New_List; 12894 12895 Append_To (Params, New_Copy_Tree (Obj)); 12896 Append_To (Params, New_Occurrence_Of (S, Loc)); 12897 Append_To (Params, 12898 Make_Attribute_Reference (Loc, 12899 Prefix => New_Occurrence_Of (P, Loc), 12900 Attribute_Name => Name_Address)); 12901 Append_To (Params, New_Occurrence_Of (D, Loc)); 12902 Append_To (Params, New_Occurrence_Of (M, Loc)); 12903 Append_To (Params, New_Occurrence_Of (C, Loc)); 12904 Append_To (Params, New_Occurrence_Of (B, Loc)); 12905 12906 Append_To (Conc_Typ_Stmts, 12907 Make_Procedure_Call_Statement (Loc, 12908 Name => 12909 New_Occurrence_Of 12910 (Find_Prim_Op 12911 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc), 12912 Parameter_Associations => Params)); 12913 12914 -- Generate: 12915 -- if C = POK_Protected_Entry 12916 -- or else C = POK_Task_Entry 12917 -- then 12918 -- Param1 := P.Param1; 12919 -- ... 12920 -- ParamN := P.ParamN; 12921 -- end if; 12922 12923 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 12924 12925 -- Generate the if statement only when the packed parameters need 12926 -- explicit assignments to their corresponding actuals. 12927 12928 if Present (Unpack) then 12929 Append_To (Conc_Typ_Stmts, 12930 Make_Implicit_If_Statement (N, 12931 12932 Condition => 12933 Make_Or_Else (Loc, 12934 Left_Opnd => 12935 Make_Op_Eq (Loc, 12936 Left_Opnd => New_Occurrence_Of (C, Loc), 12937 Right_Opnd => 12938 New_Occurrence_Of 12939 (RTE (RE_POK_Protected_Entry), Loc)), 12940 12941 Right_Opnd => 12942 Make_Op_Eq (Loc, 12943 Left_Opnd => New_Occurrence_Of (C, Loc), 12944 Right_Opnd => 12945 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 12946 12947 Then_Statements => Unpack)); 12948 end if; 12949 12950 -- Generate: 12951 12952 -- if B then 12953 -- if C = POK_Procedure 12954 -- or else C = POK_Protected_Procedure 12955 -- or else C = POK_Task_Procedure 12956 -- then 12957 -- <dispatching-call> 12958 -- end if; 12959 -- end if; 12960 12961 N_Stats := New_List ( 12962 Make_Implicit_If_Statement (N, 12963 Condition => 12964 Make_Or_Else (Loc, 12965 Left_Opnd => 12966 Make_Op_Eq (Loc, 12967 Left_Opnd => New_Occurrence_Of (C, Loc), 12968 Right_Opnd => 12969 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 12970 12971 Right_Opnd => 12972 Make_Or_Else (Loc, 12973 Left_Opnd => 12974 Make_Op_Eq (Loc, 12975 Left_Opnd => New_Occurrence_Of (C, Loc), 12976 Right_Opnd => 12977 New_Occurrence_Of (RTE ( 12978 RE_POK_Protected_Procedure), Loc)), 12979 Right_Opnd => 12980 Make_Op_Eq (Loc, 12981 Left_Opnd => New_Occurrence_Of (C, Loc), 12982 Right_Opnd => 12983 New_Occurrence_Of 12984 (RTE (RE_POK_Task_Procedure), Loc)))), 12985 12986 Then_Statements => New_List (E_Call))); 12987 12988 Append_To (Conc_Typ_Stmts, 12989 Make_Implicit_If_Statement (N, 12990 Condition => New_Occurrence_Of (B, Loc), 12991 Then_Statements => N_Stats)); 12992 12993 -- Generate: 12994 -- <dispatching-call>; 12995 -- B := True; 12996 12997 Lim_Typ_Stmts := 12998 New_List (New_Copy_Tree (E_Call), 12999 Make_Assignment_Statement (Loc, 13000 Name => New_Occurrence_Of (B, Loc), 13001 Expression => New_Occurrence_Of (Standard_True, Loc))); 13002 13003 -- Generate: 13004 -- if K = Ada.Tags.TK_Limited_Tagged 13005 -- or else K = Ada.Tags.TK_Tagged 13006 -- then 13007 -- Lim_Typ_Stmts 13008 -- else 13009 -- Conc_Typ_Stmts 13010 -- end if; 13011 13012 Append_To (Stmts, 13013 Make_Implicit_If_Statement (N, 13014 Condition => Build_Dispatching_Tag_Check (K, N), 13015 Then_Statements => Lim_Typ_Stmts, 13016 Else_Statements => Conc_Typ_Stmts)); 13017 13018 -- Generate: 13019 13020 -- if B then 13021 -- <triggering-statements> 13022 -- else 13023 -- <timed-statements> 13024 -- end if; 13025 13026 Append_To (Stmts, 13027 Make_Implicit_If_Statement (N, 13028 Condition => New_Occurrence_Of (B, Loc), 13029 Then_Statements => E_Stats, 13030 Else_Statements => D_Stats)); 13031 13032 else 13033 -- Simple case of a nondispatching trigger. Skip assignments to 13034 -- temporaries created for in-out parameters. 13035 13036 -- This makes unwarranted assumptions about the shape of the expanded 13037 -- tree for the call, and should be cleaned up ??? 13038 13039 Stmt := First (Stmts); 13040 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 13041 Next (Stmt); 13042 end loop; 13043 13044 -- Compute the delay at this stage because the evaluation of 13045 -- its expression must not occur earlier (see ACVC C97302A). 13046 13047 Insert_Before (Stmt, 13048 Make_Assignment_Statement (Loc, 13049 Name => New_Occurrence_Of (D, Loc), 13050 Expression => D_Conv)); 13051 13052 Call := Stmt; 13053 Params := Parameter_Associations (Call); 13054 13055 -- For a protected type, we build a Timed_Protected_Entry_Call 13056 13057 if Is_Protected_Type (Etype (Concval)) then 13058 13059 -- Create a new call statement 13060 13061 Param := First (Params); 13062 while Present (Param) 13063 and then not Is_RTE (Etype (Param), RE_Call_Modes) 13064 loop 13065 Next (Param); 13066 end loop; 13067 13068 Dummy := Remove_Next (Next (Param)); 13069 13070 -- Remove garbage is following the Cancel_Param if present 13071 13072 Dummy := Next (Param); 13073 13074 -- Remove the mode of the Protected_Entry_Call call, then remove 13075 -- the Communication_Block of the Protected_Entry_Call call, and 13076 -- finally add Duration and a Delay_Mode parameter 13077 13078 pragma Assert (Present (Param)); 13079 Rewrite (Param, New_Occurrence_Of (D, Loc)); 13080 13081 Rewrite (Dummy, New_Occurrence_Of (M, Loc)); 13082 13083 -- Add a Boolean flag for successful entry call 13084 13085 Append_To (Params, New_Occurrence_Of (B, Loc)); 13086 13087 case Corresponding_Runtime_Package (Etype (Concval)) is 13088 when System_Tasking_Protected_Objects_Entries => 13089 Rewrite (Call, 13090 Make_Procedure_Call_Statement (Loc, 13091 Name => 13092 New_Occurrence_Of 13093 (RTE (RE_Timed_Protected_Entry_Call), Loc), 13094 Parameter_Associations => Params)); 13095 13096 when others => 13097 raise Program_Error; 13098 end case; 13099 13100 -- For the task case, build a Timed_Task_Entry_Call 13101 13102 else 13103 -- Create a new call statement 13104 13105 Append_To (Params, New_Occurrence_Of (D, Loc)); 13106 Append_To (Params, New_Occurrence_Of (M, Loc)); 13107 Append_To (Params, New_Occurrence_Of (B, Loc)); 13108 13109 Rewrite (Call, 13110 Make_Procedure_Call_Statement (Loc, 13111 Name => 13112 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc), 13113 Parameter_Associations => Params)); 13114 end if; 13115 13116 Append_To (Stmts, 13117 Make_Implicit_If_Statement (N, 13118 Condition => New_Occurrence_Of (B, Loc), 13119 Then_Statements => E_Stats, 13120 Else_Statements => D_Stats)); 13121 end if; 13122 13123 Rewrite (N, 13124 Make_Block_Statement (Loc, 13125 Declarations => Decls, 13126 Handled_Statement_Sequence => 13127 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 13128 13129 Analyze (N); 13130 13131 -- Some items in Decls used to be in the N_Block in E_Call that is 13132 -- constructed in Expand_Entry_Call, and are now in the new Block 13133 -- into which N has been rewritten. Adjust their scopes to reflect that. 13134 13135 if Nkind (E_Call) = N_Block_Statement then 13136 Obj := First_Entity (Entity (Identifier (E_Call))); 13137 while Present (Obj) loop 13138 Set_Scope (Obj, Entity (Identifier (N))); 13139 Next_Entity (Obj); 13140 end loop; 13141 end if; 13142 13143 Reset_Scopes_To (N, Entity (Identifier (N))); 13144 end Expand_N_Timed_Entry_Call; 13145 13146 ---------------------------------------- 13147 -- Expand_Protected_Body_Declarations -- 13148 ---------------------------------------- 13149 13150 procedure Expand_Protected_Body_Declarations 13151 (N : Node_Id; 13152 Spec_Id : Entity_Id) 13153 is 13154 begin 13155 if No_Run_Time_Mode then 13156 Error_Msg_CRT ("protected body", N); 13157 return; 13158 13159 elsif Expander_Active then 13160 13161 -- Associate discriminals with the first subprogram or entry body to 13162 -- be expanded. 13163 13164 if Present (First_Protected_Operation (Declarations (N))) then 13165 Set_Discriminals (Parent (Spec_Id)); 13166 end if; 13167 end if; 13168 end Expand_Protected_Body_Declarations; 13169 13170 ------------------------- 13171 -- External_Subprogram -- 13172 ------------------------- 13173 13174 function External_Subprogram (E : Entity_Id) return Entity_Id is 13175 Subp : constant Entity_Id := Protected_Body_Subprogram (E); 13176 13177 begin 13178 -- The internal and external subprograms follow each other on the entity 13179 -- chain. Note that previously private operations had no separate 13180 -- external subprogram. We now create one in all cases, because a 13181 -- private operation may actually appear in an external call, through 13182 -- a 'Access reference used for a callback. 13183 13184 -- If the operation is a function that returns an anonymous access type, 13185 -- the corresponding itype appears before the operation, and must be 13186 -- skipped. 13187 13188 -- This mechanism is fragile, there should be a real link between the 13189 -- two versions of the operation, but there is no place to put it ??? 13190 13191 if Is_Access_Type (Next_Entity (Subp)) then 13192 return Next_Entity (Next_Entity (Subp)); 13193 else 13194 return Next_Entity (Subp); 13195 end if; 13196 end External_Subprogram; 13197 13198 ------------------------------ 13199 -- Extract_Dispatching_Call -- 13200 ------------------------------ 13201 13202 procedure Extract_Dispatching_Call 13203 (N : Node_Id; 13204 Call_Ent : out Entity_Id; 13205 Object : out Entity_Id; 13206 Actuals : out List_Id; 13207 Formals : out List_Id) 13208 is 13209 Call_Nam : Node_Id; 13210 13211 begin 13212 pragma Assert (Nkind (N) = N_Procedure_Call_Statement); 13213 13214 if Present (Original_Node (N)) then 13215 Call_Nam := Name (Original_Node (N)); 13216 else 13217 Call_Nam := Name (N); 13218 end if; 13219 13220 -- Retrieve the name of the dispatching procedure. It contains the 13221 -- dispatch table slot number. 13222 13223 loop 13224 case Nkind (Call_Nam) is 13225 when N_Identifier => 13226 exit; 13227 13228 when N_Selected_Component => 13229 Call_Nam := Selector_Name (Call_Nam); 13230 13231 when others => 13232 raise Program_Error; 13233 end case; 13234 end loop; 13235 13236 Actuals := Parameter_Associations (N); 13237 Call_Ent := Entity (Call_Nam); 13238 Formals := Parameter_Specifications (Parent (Call_Ent)); 13239 Object := First (Actuals); 13240 13241 if Present (Original_Node (Object)) then 13242 Object := Original_Node (Object); 13243 end if; 13244 13245 -- If the type of the dispatching object is an access type then return 13246 -- an explicit dereference of a copy of the object, and note that this 13247 -- is the controlling actual of the call. 13248 13249 if Is_Access_Type (Etype (Object)) then 13250 Object := 13251 Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object)); 13252 Analyze (Object); 13253 Set_Is_Controlling_Actual (Object); 13254 end if; 13255 end Extract_Dispatching_Call; 13256 13257 ------------------- 13258 -- Extract_Entry -- 13259 ------------------- 13260 13261 procedure Extract_Entry 13262 (N : Node_Id; 13263 Concval : out Node_Id; 13264 Ename : out Node_Id; 13265 Index : out Node_Id) 13266 is 13267 Nam : constant Node_Id := Name (N); 13268 13269 begin 13270 -- For a simple entry, the name is a selected component, with the 13271 -- prefix being the task value, and the selector being the entry. 13272 13273 if Nkind (Nam) = N_Selected_Component then 13274 Concval := Prefix (Nam); 13275 Ename := Selector_Name (Nam); 13276 Index := Empty; 13277 13278 -- For a member of an entry family, the name is an indexed component 13279 -- where the prefix is a selected component, whose prefix in turn is 13280 -- the task value, and whose selector is the entry family. The single 13281 -- expression in the expressions list of the indexed component is the 13282 -- subscript for the family. 13283 13284 else pragma Assert (Nkind (Nam) = N_Indexed_Component); 13285 Concval := Prefix (Prefix (Nam)); 13286 Ename := Selector_Name (Prefix (Nam)); 13287 Index := First (Expressions (Nam)); 13288 end if; 13289 13290 -- Through indirection, the type may actually be a limited view of a 13291 -- concurrent type. When compiling a call, the non-limited view of the 13292 -- type is visible. 13293 13294 if From_Limited_With (Etype (Concval)) then 13295 Set_Etype (Concval, Non_Limited_View (Etype (Concval))); 13296 end if; 13297 end Extract_Entry; 13298 13299 ------------------- 13300 -- Family_Offset -- 13301 ------------------- 13302 13303 function Family_Offset 13304 (Loc : Source_Ptr; 13305 Hi : Node_Id; 13306 Lo : Node_Id; 13307 Ttyp : Entity_Id; 13308 Cap : Boolean) return Node_Id 13309 is 13310 Ityp : Entity_Id; 13311 Real_Hi : Node_Id; 13312 Real_Lo : Node_Id; 13313 13314 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 13315 -- If one of the bounds is a reference to a discriminant, replace with 13316 -- corresponding discriminal of type. Within the body of a task retrieve 13317 -- the renamed discriminant by simple visibility, using its generated 13318 -- name. Within a protected object, find the original discriminant and 13319 -- replace it with the discriminal of the current protected operation. 13320 13321 ------------------------------ 13322 -- Convert_Discriminant_Ref -- 13323 ------------------------------ 13324 13325 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 13326 Loc : constant Source_Ptr := Sloc (Bound); 13327 B : Node_Id; 13328 D : Entity_Id; 13329 13330 begin 13331 if Is_Entity_Name (Bound) 13332 and then Ekind (Entity (Bound)) = E_Discriminant 13333 then 13334 if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then 13335 B := Make_Identifier (Loc, Chars (Entity (Bound))); 13336 Find_Direct_Name (B); 13337 13338 elsif Is_Protected_Type (Ttyp) then 13339 D := First_Discriminant (Ttyp); 13340 while Chars (D) /= Chars (Entity (Bound)) loop 13341 Next_Discriminant (D); 13342 end loop; 13343 13344 B := New_Occurrence_Of (Discriminal (D), Loc); 13345 13346 else 13347 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); 13348 end if; 13349 13350 elsif Nkind (Bound) = N_Attribute_Reference then 13351 return Bound; 13352 13353 else 13354 B := New_Copy_Tree (Bound); 13355 end if; 13356 13357 return 13358 Make_Attribute_Reference (Loc, 13359 Attribute_Name => Name_Pos, 13360 Prefix => New_Occurrence_Of (Etype (Bound), Loc), 13361 Expressions => New_List (B)); 13362 end Convert_Discriminant_Ref; 13363 13364 -- Start of processing for Family_Offset 13365 13366 begin 13367 Real_Hi := Convert_Discriminant_Ref (Hi); 13368 Real_Lo := Convert_Discriminant_Ref (Lo); 13369 13370 if Cap then 13371 if Is_Task_Type (Ttyp) then 13372 Ityp := RTE (RE_Task_Entry_Index); 13373 else 13374 Ityp := RTE (RE_Protected_Entry_Index); 13375 end if; 13376 13377 Real_Hi := 13378 Make_Attribute_Reference (Loc, 13379 Prefix => New_Occurrence_Of (Ityp, Loc), 13380 Attribute_Name => Name_Min, 13381 Expressions => New_List ( 13382 Real_Hi, 13383 Make_Integer_Literal (Loc, Entry_Family_Bound - 1))); 13384 13385 Real_Lo := 13386 Make_Attribute_Reference (Loc, 13387 Prefix => New_Occurrence_Of (Ityp, Loc), 13388 Attribute_Name => Name_Max, 13389 Expressions => New_List ( 13390 Real_Lo, 13391 Make_Integer_Literal (Loc, -Entry_Family_Bound))); 13392 end if; 13393 13394 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo); 13395 end Family_Offset; 13396 13397 ----------------- 13398 -- Family_Size -- 13399 ----------------- 13400 13401 function Family_Size 13402 (Loc : Source_Ptr; 13403 Hi : Node_Id; 13404 Lo : Node_Id; 13405 Ttyp : Entity_Id; 13406 Cap : Boolean) return Node_Id 13407 is 13408 Ityp : Entity_Id; 13409 13410 begin 13411 if Is_Task_Type (Ttyp) then 13412 Ityp := RTE (RE_Task_Entry_Index); 13413 else 13414 Ityp := RTE (RE_Protected_Entry_Index); 13415 end if; 13416 13417 return 13418 Make_Attribute_Reference (Loc, 13419 Prefix => New_Occurrence_Of (Ityp, Loc), 13420 Attribute_Name => Name_Max, 13421 Expressions => New_List ( 13422 Make_Op_Add (Loc, 13423 Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap), 13424 Right_Opnd => Make_Integer_Literal (Loc, 1)), 13425 Make_Integer_Literal (Loc, 0))); 13426 end Family_Size; 13427 13428 ---------------------------- 13429 -- Find_Enclosing_Context -- 13430 ---------------------------- 13431 13432 procedure Find_Enclosing_Context 13433 (N : Node_Id; 13434 Context : out Node_Id; 13435 Context_Id : out Entity_Id; 13436 Context_Decls : out List_Id) 13437 is 13438 begin 13439 -- Traverse the parent chain looking for an enclosing body, block, 13440 -- package or return statement. 13441 13442 Context := Parent (N); 13443 while Present (Context) loop 13444 if Nkind (Context) in N_Entry_Body 13445 | N_Extended_Return_Statement 13446 | N_Package_Body 13447 | N_Package_Declaration 13448 | N_Subprogram_Body 13449 | N_Task_Body 13450 then 13451 exit; 13452 13453 -- Do not consider block created to protect a list of statements with 13454 -- an Abort_Defer / Abort_Undefer_Direct pair. 13455 13456 elsif Nkind (Context) = N_Block_Statement 13457 and then not Is_Abort_Block (Context) 13458 then 13459 exit; 13460 end if; 13461 13462 Context := Parent (Context); 13463 end loop; 13464 13465 pragma Assert (Present (Context)); 13466 13467 -- Extract the constituents of the context 13468 13469 if Nkind (Context) = N_Extended_Return_Statement then 13470 Context_Decls := Return_Object_Declarations (Context); 13471 Context_Id := Return_Statement_Entity (Context); 13472 13473 -- Package declarations and bodies use a common library-level activation 13474 -- chain or task master, therefore return the package declaration as the 13475 -- proper carrier for the appropriate flag. 13476 13477 elsif Nkind (Context) = N_Package_Body then 13478 Context_Decls := Declarations (Context); 13479 Context_Id := Corresponding_Spec (Context); 13480 Context := Parent (Context_Id); 13481 13482 if Nkind (Context) = N_Defining_Program_Unit_Name then 13483 Context := Parent (Parent (Context)); 13484 else 13485 Context := Parent (Context); 13486 end if; 13487 13488 elsif Nkind (Context) = N_Package_Declaration then 13489 Context_Decls := Visible_Declarations (Specification (Context)); 13490 Context_Id := Defining_Unit_Name (Specification (Context)); 13491 13492 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13493 Context_Id := Defining_Identifier (Context_Id); 13494 end if; 13495 13496 else 13497 if Nkind (Context) = N_Block_Statement then 13498 Context_Id := Entity (Identifier (Context)); 13499 13500 if No (Declarations (Context)) then 13501 Set_Declarations (Context, New_List); 13502 end if; 13503 13504 elsif Nkind (Context) = N_Entry_Body then 13505 Context_Id := Defining_Identifier (Context); 13506 13507 elsif Nkind (Context) = N_Subprogram_Body then 13508 if Present (Corresponding_Spec (Context)) then 13509 Context_Id := Corresponding_Spec (Context); 13510 else 13511 Context_Id := Defining_Unit_Name (Specification (Context)); 13512 13513 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13514 Context_Id := Defining_Identifier (Context_Id); 13515 end if; 13516 end if; 13517 13518 elsif Nkind (Context) = N_Task_Body then 13519 Context_Id := Corresponding_Spec (Context); 13520 13521 else 13522 raise Program_Error; 13523 end if; 13524 13525 Context_Decls := Declarations (Context); 13526 end if; 13527 13528 pragma Assert (Present (Context_Id)); 13529 pragma Assert (Present (Context_Decls)); 13530 end Find_Enclosing_Context; 13531 13532 ----------------------- 13533 -- Find_Master_Scope -- 13534 ----------------------- 13535 13536 function Find_Master_Scope (E : Entity_Id) return Entity_Id is 13537 S : Entity_Id; 13538 13539 begin 13540 -- In Ada 2005, the master is the innermost enclosing scope that is not 13541 -- transient. If the enclosing block is the rewriting of a call or the 13542 -- scope is an extended return statement this is valid master. The 13543 -- master in an extended return is only used within the return, and is 13544 -- subsequently overwritten in Move_Activation_Chain, but it must exist 13545 -- now before that overwriting occurs. 13546 13547 S := Scope (E); 13548 13549 if Ada_Version >= Ada_2005 then 13550 while Is_Internal (S) loop 13551 if Nkind (Parent (S)) = N_Block_Statement 13552 and then Has_Master_Entity (S) 13553 then 13554 exit; 13555 13556 elsif Ekind (S) = E_Return_Statement then 13557 exit; 13558 13559 else 13560 S := Scope (S); 13561 end if; 13562 end loop; 13563 end if; 13564 13565 return S; 13566 end Find_Master_Scope; 13567 13568 ------------------------------- 13569 -- First_Protected_Operation -- 13570 ------------------------------- 13571 13572 function First_Protected_Operation (D : List_Id) return Node_Id is 13573 First_Op : Node_Id; 13574 13575 begin 13576 First_Op := First (D); 13577 while Present (First_Op) 13578 and then Nkind (First_Op) not in N_Subprogram_Body | N_Entry_Body 13579 loop 13580 Next (First_Op); 13581 end loop; 13582 13583 return First_Op; 13584 end First_Protected_Operation; 13585 13586 --------------------------------------- 13587 -- Install_Private_Data_Declarations -- 13588 --------------------------------------- 13589 13590 procedure Install_Private_Data_Declarations 13591 (Loc : Source_Ptr; 13592 Spec_Id : Entity_Id; 13593 Conc_Typ : Entity_Id; 13594 Body_Nod : Node_Id; 13595 Decls : List_Id; 13596 Barrier : Boolean := False; 13597 Family : Boolean := False) 13598 is 13599 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ); 13600 Decl : Node_Id; 13601 Def : Node_Id; 13602 Insert_Node : Node_Id := Empty; 13603 Obj_Ent : Entity_Id; 13604 13605 procedure Add (Decl : Node_Id); 13606 -- Add a single declaration after Insert_Node. If this is the first 13607 -- addition, Decl is added to the front of Decls and it becomes the 13608 -- insertion node. 13609 13610 function Replace_Bound (Bound : Node_Id) return Node_Id; 13611 -- The bounds of an entry index may depend on discriminants, create a 13612 -- reference to the corresponding prival. Otherwise return a duplicate 13613 -- of the original bound. 13614 13615 --------- 13616 -- Add -- 13617 --------- 13618 13619 procedure Add (Decl : Node_Id) is 13620 begin 13621 if No (Insert_Node) then 13622 Prepend_To (Decls, Decl); 13623 else 13624 Insert_After (Insert_Node, Decl); 13625 end if; 13626 13627 Insert_Node := Decl; 13628 end Add; 13629 13630 ------------------- 13631 -- Replace_Bound -- 13632 ------------------- 13633 13634 function Replace_Bound (Bound : Node_Id) return Node_Id is 13635 begin 13636 if Nkind (Bound) = N_Identifier 13637 and then Is_Discriminal (Entity (Bound)) 13638 then 13639 return Make_Identifier (Loc, Chars (Entity (Bound))); 13640 else 13641 return Duplicate_Subexpr (Bound); 13642 end if; 13643 end Replace_Bound; 13644 13645 -- Start of processing for Install_Private_Data_Declarations 13646 13647 begin 13648 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote 13649 -- formal parameter _O, _object or _task depending on the context. 13650 13651 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ); 13652 13653 -- Special processing of _O for barrier functions, protected entries 13654 -- and families. 13655 13656 if Barrier 13657 or else 13658 (Is_Protected 13659 and then 13660 (Ekind (Spec_Id) = E_Entry 13661 or else Ekind (Spec_Id) = E_Entry_Family)) 13662 then 13663 declare 13664 Conc_Rec : constant Entity_Id := 13665 Corresponding_Record_Type (Conc_Typ); 13666 Typ_Id : constant Entity_Id := 13667 Make_Defining_Identifier (Loc, 13668 New_External_Name (Chars (Conc_Rec), 'P')); 13669 begin 13670 -- Generate: 13671 -- type prot_typVP is access prot_typV; 13672 13673 Decl := 13674 Make_Full_Type_Declaration (Loc, 13675 Defining_Identifier => Typ_Id, 13676 Type_Definition => 13677 Make_Access_To_Object_Definition (Loc, 13678 Subtype_Indication => 13679 New_Occurrence_Of (Conc_Rec, Loc))); 13680 Add (Decl); 13681 13682 -- Generate: 13683 -- _object : prot_typVP := prot_typV (_O); 13684 13685 Decl := 13686 Make_Object_Declaration (Loc, 13687 Defining_Identifier => 13688 Make_Defining_Identifier (Loc, Name_uObject), 13689 Object_Definition => New_Occurrence_Of (Typ_Id, Loc), 13690 Expression => 13691 Unchecked_Convert_To (Typ_Id, 13692 New_Occurrence_Of (Obj_Ent, Loc))); 13693 Add (Decl); 13694 13695 -- Set the reference to the concurrent object 13696 13697 Obj_Ent := Defining_Identifier (Decl); 13698 end; 13699 end if; 13700 13701 -- Step 2: Create the Protection object and build its declaration for 13702 -- any protected entry (family) of subprogram. Note for the lock-free 13703 -- implementation, the Protection object is not needed anymore. 13704 13705 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then 13706 declare 13707 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); 13708 Prot_Typ : RE_Id; 13709 13710 begin 13711 Set_Protection_Object (Spec_Id, Prot_Ent); 13712 13713 -- Determine the proper protection type 13714 13715 if Has_Attach_Handler (Conc_Typ) 13716 and then not Restricted_Profile 13717 then 13718 Prot_Typ := RE_Static_Interrupt_Protection; 13719 13720 elsif Has_Interrupt_Handler (Conc_Typ) 13721 and then not Restriction_Active (No_Dynamic_Attachment) 13722 then 13723 Prot_Typ := RE_Dynamic_Interrupt_Protection; 13724 13725 else 13726 case Corresponding_Runtime_Package (Conc_Typ) is 13727 when System_Tasking_Protected_Objects_Entries => 13728 Prot_Typ := RE_Protection_Entries; 13729 13730 when System_Tasking_Protected_Objects_Single_Entry => 13731 Prot_Typ := RE_Protection_Entry; 13732 13733 when System_Tasking_Protected_Objects => 13734 Prot_Typ := RE_Protection; 13735 13736 when others => 13737 raise Program_Error; 13738 end case; 13739 end if; 13740 13741 -- Generate: 13742 -- conc_typR : protection_typ renames _object._object; 13743 13744 Decl := 13745 Make_Object_Renaming_Declaration (Loc, 13746 Defining_Identifier => Prot_Ent, 13747 Subtype_Mark => 13748 New_Occurrence_Of (RTE (Prot_Typ), Loc), 13749 Name => 13750 Make_Selected_Component (Loc, 13751 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13752 Selector_Name => Make_Identifier (Loc, Name_uObject))); 13753 Add (Decl); 13754 end; 13755 end if; 13756 13757 -- Step 3: Add discriminant renamings (if any) 13758 13759 if Has_Discriminants (Conc_Typ) then 13760 declare 13761 D : Entity_Id; 13762 13763 begin 13764 D := First_Discriminant (Conc_Typ); 13765 while Present (D) loop 13766 13767 -- Adjust the source location 13768 13769 Set_Sloc (Discriminal (D), Loc); 13770 13771 -- Generate: 13772 -- discr_name : discr_typ renames _object.discr_name; 13773 -- or 13774 -- discr_name : discr_typ renames _task.discr_name; 13775 13776 Decl := 13777 Make_Object_Renaming_Declaration (Loc, 13778 Defining_Identifier => Discriminal (D), 13779 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc), 13780 Name => 13781 Make_Selected_Component (Loc, 13782 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13783 Selector_Name => Make_Identifier (Loc, Chars (D)))); 13784 Add (Decl); 13785 13786 -- Set debug info needed on this renaming declaration even 13787 -- though it does not come from source, so that the debugger 13788 -- will get the right information for these generated names. 13789 13790 Set_Debug_Info_Needed (Discriminal (D)); 13791 13792 Next_Discriminant (D); 13793 end loop; 13794 end; 13795 end if; 13796 13797 -- Step 4: Add private component renamings (if any) 13798 13799 if Is_Protected then 13800 Def := Protected_Definition (Parent (Conc_Typ)); 13801 13802 if Present (Private_Declarations (Def)) then 13803 declare 13804 Comp : Node_Id; 13805 Comp_Id : Entity_Id; 13806 Decl_Id : Entity_Id; 13807 13808 begin 13809 Comp := First (Private_Declarations (Def)); 13810 while Present (Comp) loop 13811 if Nkind (Comp) = N_Component_Declaration then 13812 Comp_Id := Defining_Identifier (Comp); 13813 Decl_Id := 13814 Make_Defining_Identifier (Loc, Chars (Comp_Id)); 13815 13816 -- Minimal decoration 13817 13818 if Ekind (Spec_Id) = E_Function then 13819 Set_Ekind (Decl_Id, E_Constant); 13820 else 13821 Set_Ekind (Decl_Id, E_Variable); 13822 end if; 13823 13824 Set_Prival (Comp_Id, Decl_Id); 13825 Set_Prival_Link (Decl_Id, Comp_Id); 13826 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); 13827 Set_Is_Independent (Decl_Id, Is_Independent (Comp_Id)); 13828 13829 -- Generate: 13830 -- comp_name : comp_typ renames _object.comp_name; 13831 13832 Decl := 13833 Make_Object_Renaming_Declaration (Loc, 13834 Defining_Identifier => Decl_Id, 13835 Subtype_Mark => 13836 New_Occurrence_Of (Etype (Comp_Id), Loc), 13837 Name => 13838 Make_Selected_Component (Loc, 13839 Prefix => 13840 New_Occurrence_Of (Obj_Ent, Loc), 13841 Selector_Name => 13842 Make_Identifier (Loc, Chars (Comp_Id)))); 13843 Add (Decl); 13844 end if; 13845 13846 Next (Comp); 13847 end loop; 13848 end; 13849 end if; 13850 end if; 13851 13852 -- Step 5: Add the declaration of the entry index and the associated 13853 -- type for barrier functions and entry families. 13854 13855 if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then 13856 declare 13857 E : constant Entity_Id := Index_Object (Spec_Id); 13858 Index : constant Entity_Id := 13859 Defining_Identifier 13860 (Entry_Index_Specification 13861 (Entry_Body_Formal_Part (Body_Nod))); 13862 Index_Con : constant Entity_Id := 13863 Make_Defining_Identifier (Loc, Chars (Index)); 13864 High : Node_Id; 13865 Index_Typ : Entity_Id; 13866 Low : Node_Id; 13867 13868 begin 13869 -- Minimal decoration 13870 13871 Set_Ekind (Index_Con, E_Constant); 13872 Set_Entry_Index_Constant (Index, Index_Con); 13873 Set_Discriminal_Link (Index_Con, Index); 13874 13875 -- Retrieve the bounds of the entry family 13876 13877 High := Type_High_Bound (Etype (Index)); 13878 Low := Type_Low_Bound (Etype (Index)); 13879 13880 -- In the simple case the entry family is given by a subtype mark 13881 -- and the index constant has the same type. 13882 13883 if Is_Entity_Name (Original_Node ( 13884 Discrete_Subtype_Definition (Parent (Index)))) 13885 then 13886 Index_Typ := Etype (Index); 13887 13888 -- Otherwise a new subtype declaration is required 13889 13890 else 13891 High := Replace_Bound (High); 13892 Low := Replace_Bound (Low); 13893 13894 Index_Typ := Make_Temporary (Loc, 'J'); 13895 13896 -- Generate: 13897 -- subtype Jnn is <Etype of Index> range Low .. High; 13898 13899 Decl := 13900 Make_Subtype_Declaration (Loc, 13901 Defining_Identifier => Index_Typ, 13902 Subtype_Indication => 13903 Make_Subtype_Indication (Loc, 13904 Subtype_Mark => 13905 New_Occurrence_Of (Base_Type (Etype (Index)), Loc), 13906 Constraint => 13907 Make_Range_Constraint (Loc, 13908 Range_Expression => 13909 Make_Range (Loc, Low, High)))); 13910 Add (Decl); 13911 end if; 13912 13913 Set_Etype (Index_Con, Index_Typ); 13914 13915 -- Create the object which designates the index: 13916 -- J : constant Jnn := 13917 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First)); 13918 -- 13919 -- where Jnn is the subtype created above or the original type of 13920 -- the index, _E is a formal of the protected body subprogram and 13921 -- <index expr> is the index of the first family member. 13922 13923 Decl := 13924 Make_Object_Declaration (Loc, 13925 Defining_Identifier => Index_Con, 13926 Constant_Present => True, 13927 Object_Definition => 13928 New_Occurrence_Of (Index_Typ, Loc), 13929 13930 Expression => 13931 Make_Attribute_Reference (Loc, 13932 Prefix => 13933 New_Occurrence_Of (Index_Typ, Loc), 13934 Attribute_Name => Name_Val, 13935 13936 Expressions => New_List ( 13937 13938 Make_Op_Add (Loc, 13939 Left_Opnd => 13940 Make_Op_Subtract (Loc, 13941 Left_Opnd => New_Occurrence_Of (E, Loc), 13942 Right_Opnd => 13943 Entry_Index_Expression (Loc, 13944 Defining_Identifier (Body_Nod), 13945 Empty, Conc_Typ)), 13946 13947 Right_Opnd => 13948 Make_Attribute_Reference (Loc, 13949 Prefix => 13950 New_Occurrence_Of (Index_Typ, Loc), 13951 Attribute_Name => Name_Pos, 13952 Expressions => New_List ( 13953 Make_Attribute_Reference (Loc, 13954 Prefix => 13955 New_Occurrence_Of (Index_Typ, Loc), 13956 Attribute_Name => Name_First))))))); 13957 Add (Decl); 13958 end; 13959 end if; 13960 end Install_Private_Data_Declarations; 13961 13962 --------------------------------- 13963 -- Is_Potentially_Large_Family -- 13964 --------------------------------- 13965 13966 function Is_Potentially_Large_Family 13967 (Base_Index : Entity_Id; 13968 Conctyp : Entity_Id; 13969 Lo : Node_Id; 13970 Hi : Node_Id) return Boolean 13971 is 13972 begin 13973 return Scope (Base_Index) = Standard_Standard 13974 and then Base_Index = Base_Type (Standard_Integer) 13975 and then Has_Discriminants (Conctyp) 13976 and then 13977 Present (Discriminant_Default_Value (First_Discriminant (Conctyp))) 13978 and then 13979 (Denotes_Discriminant (Lo, True) 13980 or else 13981 Denotes_Discriminant (Hi, True)); 13982 end Is_Potentially_Large_Family; 13983 13984 ------------------------------------- 13985 -- Is_Private_Primitive_Subprogram -- 13986 ------------------------------------- 13987 13988 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is 13989 begin 13990 return 13991 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure) 13992 and then Is_Private_Primitive (Id); 13993 end Is_Private_Primitive_Subprogram; 13994 13995 ------------------ 13996 -- Index_Object -- 13997 ------------------ 13998 13999 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is 14000 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id); 14001 Formal : Entity_Id; 14002 14003 begin 14004 Formal := First_Formal (Bod_Subp); 14005 while Present (Formal) loop 14006 14007 -- Look for formal parameter _E 14008 14009 if Chars (Formal) = Name_uE then 14010 return Formal; 14011 end if; 14012 14013 Next_Formal (Formal); 14014 end loop; 14015 14016 -- A protected body subprogram should always have the parameter in 14017 -- question. 14018 14019 raise Program_Error; 14020 end Index_Object; 14021 14022 -------------------------------- 14023 -- Make_Initialize_Protection -- 14024 -------------------------------- 14025 14026 function Make_Initialize_Protection 14027 (Protect_Rec : Entity_Id) return List_Id 14028 is 14029 Loc : constant Source_Ptr := Sloc (Protect_Rec); 14030 P_Arr : Entity_Id; 14031 Pdec : Node_Id; 14032 Ptyp : constant Node_Id := 14033 Corresponding_Concurrent_Type (Protect_Rec); 14034 Args : List_Id; 14035 L : constant List_Id := New_List; 14036 Has_Entry : constant Boolean := Has_Entries (Ptyp); 14037 Prio_Type : Entity_Id; 14038 Prio_Var : Entity_Id := Empty; 14039 Restricted : constant Boolean := Restricted_Profile; 14040 14041 begin 14042 -- We may need two calls to properly initialize the object, one to 14043 -- Initialize_Protection, and possibly one to Install_Handlers if we 14044 -- have a pragma Attach_Handler. 14045 14046 -- Get protected declaration. In the case of a task type declaration, 14047 -- this is simply the parent of the protected type entity. In the single 14048 -- protected object declaration, this parent will be the implicit type, 14049 -- and we can find the corresponding single protected object declaration 14050 -- by searching forward in the declaration list in the tree. 14051 14052 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes 14053 -- of this type should have been removed during semantic analysis. 14054 14055 Pdec := Parent (Ptyp); 14056 while Nkind (Pdec) not in 14057 N_Protected_Type_Declaration | N_Single_Protected_Declaration 14058 loop 14059 Next (Pdec); 14060 end loop; 14061 14062 -- Build the parameter list for the call. Note that _Init is the name 14063 -- of the formal for the object to be initialized, which is the task 14064 -- value record itself. 14065 14066 Args := New_List; 14067 14068 -- For lock-free implementation, skip initializations of the Protection 14069 -- object. 14070 14071 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 14072 14073 -- Object parameter. This is a pointer to the object of type 14074 -- Protection used by the GNARL to control the protected object. 14075 14076 Append_To (Args, 14077 Make_Attribute_Reference (Loc, 14078 Prefix => 14079 Make_Selected_Component (Loc, 14080 Prefix => Make_Identifier (Loc, Name_uInit), 14081 Selector_Name => Make_Identifier (Loc, Name_uObject)), 14082 Attribute_Name => Name_Unchecked_Access)); 14083 14084 -- Priority parameter. Set to Unspecified_Priority unless there is a 14085 -- Priority rep item, in which case we take the value from the pragma 14086 -- or attribute definition clause, or there is an Interrupt_Priority 14087 -- rep item and no Priority rep item, and we set the ceiling to 14088 -- Interrupt_Priority'Last, an implementation-defined value, see 14089 -- (RM D.3(10)). 14090 14091 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then 14092 declare 14093 Prio_Clause : constant Node_Id := 14094 Get_Rep_Item 14095 (Ptyp, Name_Priority, Check_Parents => False); 14096 14097 Prio : Node_Id; 14098 14099 begin 14100 -- Pragma Priority 14101 14102 if Nkind (Prio_Clause) = N_Pragma then 14103 Prio := 14104 Expression 14105 (First (Pragma_Argument_Associations (Prio_Clause))); 14106 14107 -- Get_Rep_Item returns either priority pragma 14108 14109 if Pragma_Name (Prio_Clause) = Name_Priority then 14110 Prio_Type := RTE (RE_Any_Priority); 14111 else 14112 Prio_Type := RTE (RE_Interrupt_Priority); 14113 end if; 14114 14115 -- Attribute definition clause Priority 14116 14117 else 14118 if Chars (Prio_Clause) = Name_Priority then 14119 Prio_Type := RTE (RE_Any_Priority); 14120 else 14121 Prio_Type := RTE (RE_Interrupt_Priority); 14122 end if; 14123 14124 Prio := Expression (Prio_Clause); 14125 end if; 14126 14127 -- Always create a locale variable to capture the priority. 14128 -- The priority is also passed to Install_Restriced_Handlers. 14129 -- Note that it is really necessary to create this variable 14130 -- explicitly. It might be thought that removing side effects 14131 -- would the appropriate approach, but that could generate 14132 -- declarations improperly placed in the enclosing scope. 14133 14134 Prio_Var := Make_Temporary (Loc, 'R', Prio); 14135 Append_To (L, 14136 Make_Object_Declaration (Loc, 14137 Defining_Identifier => Prio_Var, 14138 Object_Definition => New_Occurrence_Of (Prio_Type, Loc), 14139 Expression => Relocate_Node (Prio))); 14140 14141 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 14142 end; 14143 14144 -- When no priority is specified but an xx_Handler pragma is, we 14145 -- default to System.Interrupts.Default_Interrupt_Priority, see 14146 -- D.3(10). 14147 14148 elsif Has_Attach_Handler (Ptyp) 14149 or else Has_Interrupt_Handler (Ptyp) 14150 then 14151 Append_To (Args, 14152 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc)); 14153 14154 -- Normal case, no priority or xx_Handler specified, default priority 14155 14156 else 14157 Append_To (Args, 14158 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 14159 end if; 14160 14161 -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes 14162 14163 if Restricted_Profile and Task_Dispatching_Policy = 'E' then 14164 Deadline_Floor : declare 14165 Item : constant Node_Id := 14166 Get_Rep_Item 14167 (Ptyp, Name_Deadline_Floor, Check_Parents => False); 14168 14169 Deadline : Node_Id; 14170 14171 begin 14172 if Present (Item) then 14173 14174 -- Pragma Deadline_Floor 14175 14176 if Nkind (Item) = N_Pragma then 14177 Deadline := 14178 Expression 14179 (First (Pragma_Argument_Associations (Item))); 14180 14181 -- Attribute definition clause Deadline_Floor 14182 14183 else 14184 pragma Assert 14185 (Nkind (Item) = N_Attribute_Definition_Clause); 14186 14187 Deadline := Expression (Item); 14188 end if; 14189 14190 Append_To (Args, Deadline); 14191 14192 -- Unusual case: default deadline 14193 14194 else 14195 Append_To (Args, 14196 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 14197 end if; 14198 end Deadline_Floor; 14199 end if; 14200 14201 -- Test for Compiler_Info parameter. This parameter allows entry body 14202 -- procedures and barrier functions to be called from the runtime. It 14203 -- is a pointer to the record generated by the compiler to represent 14204 -- the protected object. 14205 14206 -- A protected type without entries that covers an interface and 14207 -- overrides the abstract routines with protected procedures is 14208 -- considered equivalent to a protected type with entries in the 14209 -- context of dispatching select statements. 14210 14211 -- Protected types with interrupt handlers (when not using a 14212 -- restricted profile) are also considered equivalent to protected 14213 -- types with entries. 14214 14215 -- The types which are used (Static_Interrupt_Protection and 14216 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries. 14217 14218 declare 14219 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); 14220 14221 Called_Subp : RE_Id; 14222 14223 begin 14224 case Pkg_Id is 14225 when System_Tasking_Protected_Objects_Entries => 14226 Called_Subp := RE_Initialize_Protection_Entries; 14227 14228 -- Argument Compiler_Info 14229 14230 Append_To (Args, 14231 Make_Attribute_Reference (Loc, 14232 Prefix => Make_Identifier (Loc, Name_uInit), 14233 Attribute_Name => Name_Address)); 14234 14235 when System_Tasking_Protected_Objects_Single_Entry => 14236 Called_Subp := RE_Initialize_Protection_Entry; 14237 14238 -- Argument Compiler_Info 14239 14240 Append_To (Args, 14241 Make_Attribute_Reference (Loc, 14242 Prefix => Make_Identifier (Loc, Name_uInit), 14243 Attribute_Name => Name_Address)); 14244 14245 when System_Tasking_Protected_Objects => 14246 Called_Subp := RE_Initialize_Protection; 14247 14248 when others => 14249 raise Program_Error; 14250 end case; 14251 14252 -- Entry_Queue_Maxes parameter. This is an access to an array of 14253 -- naturals representing the entry queue maximums for each entry 14254 -- in the protected type. Zero represents no max. The access is 14255 -- null if there is no limit for all entries (usual case). 14256 14257 if Has_Entry 14258 and then Pkg_Id = System_Tasking_Protected_Objects_Entries 14259 then 14260 if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then 14261 Append_To (Args, 14262 Make_Attribute_Reference (Loc, 14263 Prefix => 14264 New_Occurrence_Of 14265 (Entry_Max_Queue_Lengths_Array (Ptyp), Loc), 14266 Attribute_Name => Name_Unrestricted_Access)); 14267 else 14268 Append_To (Args, Make_Null (Loc)); 14269 end if; 14270 14271 -- Edge cases exist where entry initialization functions are 14272 -- called, but no entries exist, so null is appended. 14273 14274 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 14275 Append_To (Args, Make_Null (Loc)); 14276 end if; 14277 14278 -- Entry_Bodies parameter. This is a pointer to an array of 14279 -- pointers to the entry body procedures and barrier functions of 14280 -- the object. If the protected type has no entries this object 14281 -- will not exist, in this case, pass a null (it can happen when 14282 -- there are protected interrupt handlers or interfaces). 14283 14284 if Has_Entry then 14285 P_Arr := Entry_Bodies_Array (Ptyp); 14286 14287 -- Argument Entry_Body (for single entry) or Entry_Bodies (for 14288 -- multiple entries). 14289 14290 Append_To (Args, 14291 Make_Attribute_Reference (Loc, 14292 Prefix => New_Occurrence_Of (P_Arr, Loc), 14293 Attribute_Name => Name_Unrestricted_Access)); 14294 14295 if Pkg_Id = System_Tasking_Protected_Objects_Entries then 14296 14297 -- Find index mapping function (clumsy but ok for now) 14298 14299 while Ekind (P_Arr) /= E_Function loop 14300 Next_Entity (P_Arr); 14301 end loop; 14302 14303 Append_To (Args, 14304 Make_Attribute_Reference (Loc, 14305 Prefix => New_Occurrence_Of (P_Arr, Loc), 14306 Attribute_Name => Name_Unrestricted_Access)); 14307 end if; 14308 14309 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then 14310 14311 -- This is the case where we have a protected object with 14312 -- interfaces and no entries, and the single entry restriction 14313 -- is in effect. We pass a null pointer for the entry 14314 -- parameter because there is no actual entry. 14315 14316 Append_To (Args, Make_Null (Loc)); 14317 14318 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 14319 14320 -- This is the case where we have a protected object with no 14321 -- entries and: 14322 -- - either interrupt handlers with non restricted profile, 14323 -- - or interfaces 14324 -- Note that the types which are used for interrupt handlers 14325 -- (Static/Dynamic_Interrupt_Protection) are derived from 14326 -- Protection_Entries. We pass two null pointers because there 14327 -- is no actual entry, and the initialization procedure needs 14328 -- both Entry_Bodies and Find_Body_Index. 14329 14330 Append_To (Args, Make_Null (Loc)); 14331 Append_To (Args, Make_Null (Loc)); 14332 end if; 14333 14334 Append_To (L, 14335 Make_Procedure_Call_Statement (Loc, 14336 Name => 14337 New_Occurrence_Of (RTE (Called_Subp), Loc), 14338 Parameter_Associations => Args)); 14339 end; 14340 end if; 14341 14342 if Has_Attach_Handler (Ptyp) then 14343 14344 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to 14345 -- make the following call: 14346 14347 -- Install_Handlers (_object, 14348 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 14349 14350 -- or, in the case of Ravenscar: 14351 14352 -- Install_Restricted_Handlers 14353 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access))); 14354 14355 declare 14356 Args : constant List_Id := New_List; 14357 Table : constant List_Id := New_List; 14358 Ritem : Node_Id := First_Rep_Item (Ptyp); 14359 14360 begin 14361 -- Build the Priority parameter (only for ravenscar) 14362 14363 if Restricted then 14364 14365 -- Priority comes from a pragma 14366 14367 if Present (Prio_Var) then 14368 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 14369 14370 -- Priority is the default one 14371 14372 else 14373 Append_To (Args, 14374 New_Occurrence_Of 14375 (RTE (RE_Default_Interrupt_Priority), Loc)); 14376 end if; 14377 end if; 14378 14379 -- Build the Attach_Handler table argument 14380 14381 while Present (Ritem) loop 14382 if Nkind (Ritem) = N_Pragma 14383 and then Pragma_Name (Ritem) = Name_Attach_Handler 14384 then 14385 declare 14386 Handler : constant Node_Id := 14387 First (Pragma_Argument_Associations (Ritem)); 14388 14389 Interrupt : constant Node_Id := Next (Handler); 14390 Expr : constant Node_Id := Expression (Interrupt); 14391 14392 begin 14393 Append_To (Table, 14394 Make_Aggregate (Loc, Expressions => New_List ( 14395 Unchecked_Convert_To 14396 (RTE (RE_System_Interrupt_Id), Expr), 14397 Make_Attribute_Reference (Loc, 14398 Prefix => 14399 Make_Selected_Component (Loc, 14400 Prefix => 14401 Make_Identifier (Loc, Name_uInit), 14402 Selector_Name => 14403 Duplicate_Subexpr_No_Checks 14404 (Expression (Handler))), 14405 Attribute_Name => Name_Access)))); 14406 end; 14407 end if; 14408 14409 Next_Rep_Item (Ritem); 14410 end loop; 14411 14412 -- Append the table argument we just built 14413 14414 Append_To (Args, Make_Aggregate (Loc, Table)); 14415 14416 -- Append the Install_Handlers (or Install_Restricted_Handlers) 14417 -- call to the statements. 14418 14419 if Restricted then 14420 -- Call a simplified version of Install_Handlers to be used 14421 -- when the Ravenscar restrictions are in effect 14422 -- (Install_Restricted_Handlers). 14423 14424 Append_To (L, 14425 Make_Procedure_Call_Statement (Loc, 14426 Name => 14427 New_Occurrence_Of 14428 (RTE (RE_Install_Restricted_Handlers), Loc), 14429 Parameter_Associations => Args)); 14430 14431 else 14432 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 14433 14434 -- First, prepends the _object argument 14435 14436 Prepend_To (Args, 14437 Make_Attribute_Reference (Loc, 14438 Prefix => 14439 Make_Selected_Component (Loc, 14440 Prefix => Make_Identifier (Loc, Name_uInit), 14441 Selector_Name => 14442 Make_Identifier (Loc, Name_uObject)), 14443 Attribute_Name => Name_Unchecked_Access)); 14444 end if; 14445 14446 -- Then, insert call to Install_Handlers 14447 14448 Append_To (L, 14449 Make_Procedure_Call_Statement (Loc, 14450 Name => 14451 New_Occurrence_Of (RTE (RE_Install_Handlers), Loc), 14452 Parameter_Associations => Args)); 14453 end if; 14454 end; 14455 end if; 14456 14457 return L; 14458 end Make_Initialize_Protection; 14459 14460 --------------------------- 14461 -- Make_Task_Create_Call -- 14462 --------------------------- 14463 14464 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is 14465 Loc : constant Source_Ptr := Sloc (Task_Rec); 14466 Args : List_Id; 14467 Ecount : Node_Id; 14468 Name : Node_Id; 14469 Tdec : Node_Id; 14470 Tdef : Node_Id; 14471 Tnam : Name_Id; 14472 Ttyp : Node_Id; 14473 14474 begin 14475 Ttyp := Corresponding_Concurrent_Type (Task_Rec); 14476 Tnam := Chars (Ttyp); 14477 14478 -- Get task declaration. In the case of a task type declaration, this is 14479 -- simply the parent of the task type entity. In the single task 14480 -- declaration, this parent will be the implicit type, and we can find 14481 -- the corresponding single task declaration by searching forward in the 14482 -- declaration list in the tree. 14483 14484 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of 14485 -- this type should have been removed during semantic analysis. 14486 14487 Tdec := Parent (Ttyp); 14488 while Nkind (Tdec) not in 14489 N_Task_Type_Declaration | N_Single_Task_Declaration 14490 loop 14491 Next (Tdec); 14492 end loop; 14493 14494 -- Now we can find the task definition from this declaration 14495 14496 Tdef := Task_Definition (Tdec); 14497 14498 -- Build the parameter list for the call. Note that _Init is the name 14499 -- of the formal for the object to be initialized, which is the task 14500 -- value record itself. 14501 14502 Args := New_List; 14503 14504 -- Priority parameter. Set to Unspecified_Priority unless there is a 14505 -- Priority rep item, in which case we take the value from the rep item. 14506 -- Not used on Ravenscar_EDF profile. 14507 14508 if not (Restricted_Profile and then Task_Dispatching_Policy = 'E') then 14509 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then 14510 Append_To (Args, 14511 Make_Selected_Component (Loc, 14512 Prefix => Make_Identifier (Loc, Name_uInit), 14513 Selector_Name => Make_Identifier (Loc, Name_uPriority))); 14514 else 14515 Append_To (Args, 14516 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 14517 end if; 14518 end if; 14519 14520 -- Optional Stack parameter 14521 14522 if Restricted_Profile then 14523 14524 -- If the stack has been preallocated by the expander then 14525 -- pass its address. Otherwise, pass a null address. 14526 14527 if Preallocated_Stacks_On_Target then 14528 Append_To (Args, 14529 Make_Attribute_Reference (Loc, 14530 Prefix => 14531 Make_Selected_Component (Loc, 14532 Prefix => Make_Identifier (Loc, Name_uInit), 14533 Selector_Name => Make_Identifier (Loc, Name_uStack)), 14534 Attribute_Name => Name_Address)); 14535 14536 else 14537 Append_To (Args, 14538 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 14539 end if; 14540 end if; 14541 14542 -- Size parameter. If no Storage_Size pragma is present, then 14543 -- the size is taken from the taskZ variable for the type, which 14544 -- is either Unspecified_Size, or has been reset by the use of 14545 -- a Storage_Size attribute definition clause. If a pragma is 14546 -- present, then the size is taken from the _Size field of the 14547 -- task value record, which was set from the pragma value. 14548 14549 if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then 14550 Append_To (Args, 14551 Make_Selected_Component (Loc, 14552 Prefix => Make_Identifier (Loc, Name_uInit), 14553 Selector_Name => Make_Identifier (Loc, Name_uSize))); 14554 14555 else 14556 Append_To (Args, 14557 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc)); 14558 end if; 14559 14560 -- Secondary_Stack parameter used for restricted profiles 14561 14562 if Restricted_Profile then 14563 14564 -- If the secondary stack has been allocated by the expander then 14565 -- pass its access pointer. Otherwise, pass null. 14566 14567 if Create_Secondary_Stack_For_Task (Ttyp) then 14568 Append_To (Args, 14569 Make_Attribute_Reference (Loc, 14570 Prefix => 14571 Make_Selected_Component (Loc, 14572 Prefix => Make_Identifier (Loc, Name_uInit), 14573 Selector_Name => 14574 Make_Identifier (Loc, Name_uSecondary_Stack)), 14575 Attribute_Name => Name_Unrestricted_Access)); 14576 14577 else 14578 Append_To (Args, Make_Null (Loc)); 14579 end if; 14580 end if; 14581 14582 -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there 14583 -- is a Secondary_Stack_Size pragma, in which case take the value from 14584 -- the pragma. If the restriction No_Secondary_Stack is active then a 14585 -- size of 0 is passed regardless to prevent the allocation of the 14586 -- unused stack. 14587 14588 if Restriction_Active (No_Secondary_Stack) then 14589 Append_To (Args, Make_Integer_Literal (Loc, 0)); 14590 14591 elsif Has_Rep_Pragma 14592 (Ttyp, Name_Secondary_Stack_Size, Check_Parents => False) 14593 then 14594 Append_To (Args, 14595 Make_Selected_Component (Loc, 14596 Prefix => Make_Identifier (Loc, Name_uInit), 14597 Selector_Name => 14598 Make_Identifier (Loc, Name_uSecondary_Stack_Size))); 14599 14600 else 14601 Append_To (Args, 14602 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 14603 end if; 14604 14605 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a 14606 -- Task_Info pragma, in which case we take the value from the pragma. 14607 14608 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then 14609 Append_To (Args, 14610 Make_Selected_Component (Loc, 14611 Prefix => Make_Identifier (Loc, Name_uInit), 14612 Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); 14613 14614 else 14615 Append_To (Args, 14616 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc)); 14617 end if; 14618 14619 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item, 14620 -- in which case we take the value from the rep item. The parameter is 14621 -- passed as an Integer because in the case of unspecified CPU the 14622 -- value is not in the range of CPU_Range. 14623 14624 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then 14625 Append_To (Args, 14626 Convert_To (Standard_Integer, 14627 Make_Selected_Component (Loc, 14628 Prefix => Make_Identifier (Loc, Name_uInit), 14629 Selector_Name => Make_Identifier (Loc, Name_uCPU)))); 14630 else 14631 Append_To (Args, 14632 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc)); 14633 end if; 14634 14635 if not Restricted_Profile or else Task_Dispatching_Policy = 'E' then 14636 14637 -- Deadline parameter. If no Relative_Deadline pragma is present, 14638 -- then the deadline is Time_Span_Zero. If a pragma is present, then 14639 -- the deadline is taken from the _Relative_Deadline field of the 14640 -- task value record, which was set from the pragma value. Note that 14641 -- this parameter must not be generated for the restricted profiles 14642 -- since Ravenscar does not allow deadlines. 14643 14644 -- Case where pragma Relative_Deadline applies: use given value 14645 14646 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then 14647 Append_To (Args, 14648 Make_Selected_Component (Loc, 14649 Prefix => Make_Identifier (Loc, Name_uInit), 14650 Selector_Name => 14651 Make_Identifier (Loc, Name_uRelative_Deadline))); 14652 14653 -- No pragma Relative_Deadline apply to the task 14654 14655 else 14656 Append_To (Args, 14657 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 14658 end if; 14659 end if; 14660 14661 if not Restricted_Profile then 14662 14663 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is 14664 -- present, then the dispatching domain is null. If a rep item is 14665 -- present, then the dispatching domain is taken from the 14666 -- _Dispatching_Domain field of the task value record, which was set 14667 -- from the rep item value. 14668 14669 -- Case where Dispatching_Domain rep item applies: use given value 14670 14671 if Has_Rep_Item 14672 (Ttyp, Name_Dispatching_Domain, Check_Parents => False) 14673 then 14674 Append_To (Args, 14675 Make_Selected_Component (Loc, 14676 Prefix => 14677 Make_Identifier (Loc, Name_uInit), 14678 Selector_Name => 14679 Make_Identifier (Loc, Name_uDispatching_Domain))); 14680 14681 -- No pragma or aspect Dispatching_Domain applies to the task 14682 14683 else 14684 Append_To (Args, Make_Null (Loc)); 14685 end if; 14686 14687 -- Number of entries. This is an expression of the form: 14688 14689 -- n + _Init.a'Length + _Init.a'B'Length + ... 14690 14691 -- where a,b... are the entry family names for the task definition 14692 14693 Ecount := 14694 Build_Entry_Count_Expression 14695 (Ttyp, 14696 Component_Items 14697 (Component_List 14698 (Type_Definition 14699 (Parent (Corresponding_Record_Type (Ttyp))))), 14700 Loc); 14701 Append_To (Args, Ecount); 14702 14703 -- Master parameter. This is a reference to the _Master parameter of 14704 -- the initialization procedure, except in the case of the pragma 14705 -- Restrictions (No_Task_Hierarchy) where the value is fixed to 14706 -- System.Tasking.Library_Task_Level. 14707 14708 if Restriction_Active (No_Task_Hierarchy) = False then 14709 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 14710 else 14711 Append_To (Args, 14712 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 14713 end if; 14714 end if; 14715 14716 -- State parameter. This is a pointer to the task body procedure. The 14717 -- required value is obtained by taking 'Unrestricted_Access of the task 14718 -- body procedure and converting it (with an unchecked conversion) to 14719 -- the type required by the task kernel. For further details, see the 14720 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather 14721 -- than 'Address in order to avoid creating trampolines. 14722 14723 declare 14724 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp); 14725 Subp_Ptr_Typ : constant Node_Id := 14726 Create_Itype (E_Access_Subprogram_Type, Tdec); 14727 Ref : constant Node_Id := Make_Itype_Reference (Loc); 14728 14729 begin 14730 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc); 14731 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); 14732 14733 -- Be sure to freeze a reference to the access-to-subprogram type, 14734 -- otherwise gigi will complain that it's in the wrong scope, because 14735 -- it's actually inside the init procedure for the record type that 14736 -- corresponds to the task type. 14737 14738 Set_Itype (Ref, Subp_Ptr_Typ); 14739 Append_Freeze_Action (Task_Rec, Ref); 14740 14741 Append_To (Args, 14742 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), 14743 Make_Qualified_Expression (Loc, 14744 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), 14745 Expression => 14746 Make_Attribute_Reference (Loc, 14747 Prefix => New_Occurrence_Of (Body_Proc, Loc), 14748 Attribute_Name => Name_Unrestricted_Access)))); 14749 end; 14750 14751 -- Discriminants parameter. This is just the address of the task 14752 -- value record itself (which contains the discriminant values 14753 14754 Append_To (Args, 14755 Make_Attribute_Reference (Loc, 14756 Prefix => Make_Identifier (Loc, Name_uInit), 14757 Attribute_Name => Name_Address)); 14758 14759 -- Elaborated parameter. This is an access to the elaboration Boolean 14760 14761 Append_To (Args, 14762 Make_Attribute_Reference (Loc, 14763 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')), 14764 Attribute_Name => Name_Unchecked_Access)); 14765 14766 -- Add Chain parameter (not done for sequential elaboration policy, see 14767 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 14768 14769 if Partition_Elaboration_Policy /= 'S' then 14770 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 14771 end if; 14772 14773 -- Task name parameter. Take this from the _Task_Id parameter to the 14774 -- init call unless there is a Task_Name pragma, in which case we take 14775 -- the value from the pragma. 14776 14777 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then 14778 -- Copy expression in full, because it may be dynamic and have 14779 -- side effects. 14780 14781 Append_To (Args, 14782 New_Copy_Tree 14783 (Expression 14784 (First 14785 (Pragma_Argument_Associations 14786 (Get_Rep_Pragma 14787 (Ttyp, Name_Task_Name, Check_Parents => False)))))); 14788 14789 else 14790 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); 14791 end if; 14792 14793 -- Created_Task parameter. This is the _Task_Id field of the task 14794 -- record value 14795 14796 Append_To (Args, 14797 Make_Selected_Component (Loc, 14798 Prefix => Make_Identifier (Loc, Name_uInit), 14799 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); 14800 14801 declare 14802 Create_RE : RE_Id; 14803 14804 begin 14805 if Restricted_Profile then 14806 if Partition_Elaboration_Policy = 'S' then 14807 Create_RE := RE_Create_Restricted_Task_Sequential; 14808 else 14809 Create_RE := RE_Create_Restricted_Task; 14810 end if; 14811 else 14812 Create_RE := RE_Create_Task; 14813 end if; 14814 14815 Name := New_Occurrence_Of (RTE (Create_RE), Loc); 14816 end; 14817 14818 return 14819 Make_Procedure_Call_Statement (Loc, 14820 Name => Name, 14821 Parameter_Associations => Args); 14822 end Make_Task_Create_Call; 14823 14824 ------------------------------ 14825 -- Next_Protected_Operation -- 14826 ------------------------------ 14827 14828 function Next_Protected_Operation (N : Node_Id) return Node_Id is 14829 Next_Op : Node_Id; 14830 14831 begin 14832 -- Check whether there is a subsequent body for a protected operation 14833 -- in the current protected body. In Ada2012 that includes expression 14834 -- functions that are completions. 14835 14836 Next_Op := Next (N); 14837 while Present (Next_Op) 14838 and then Nkind (Next_Op) not in 14839 N_Subprogram_Body | N_Entry_Body | N_Expression_Function 14840 loop 14841 Next (Next_Op); 14842 end loop; 14843 14844 return Next_Op; 14845 end Next_Protected_Operation; 14846 14847 --------------------- 14848 -- Null_Statements -- 14849 --------------------- 14850 14851 function Null_Statements (Stats : List_Id) return Boolean is 14852 Stmt : Node_Id; 14853 14854 begin 14855 Stmt := First (Stats); 14856 while Nkind (Stmt) /= N_Empty 14857 and then (Nkind (Stmt) in N_Null_Statement | N_Label 14858 or else 14859 (Nkind (Stmt) = N_Pragma 14860 and then 14861 Pragma_Name_Unmapped (Stmt) in Name_Unreferenced 14862 | Name_Unmodified 14863 | Name_Warnings)) 14864 loop 14865 Next (Stmt); 14866 end loop; 14867 14868 return Nkind (Stmt) = N_Empty; 14869 end Null_Statements; 14870 14871 -------------------------- 14872 -- Parameter_Block_Pack -- 14873 -------------------------- 14874 14875 function Parameter_Block_Pack 14876 (Loc : Source_Ptr; 14877 Blk_Typ : Entity_Id; 14878 Actuals : List_Id; 14879 Formals : List_Id; 14880 Decls : List_Id; 14881 Stmts : List_Id) return Node_Id 14882 is 14883 Actual : Entity_Id; 14884 Expr : Node_Id := Empty; 14885 Formal : Entity_Id; 14886 Has_Param : Boolean := False; 14887 P : Entity_Id; 14888 Params : List_Id; 14889 Temp_Asn : Node_Id; 14890 Temp_Nam : Node_Id; 14891 14892 begin 14893 Actual := First (Actuals); 14894 Formal := Defining_Identifier (First (Formals)); 14895 Params := New_List; 14896 while Present (Actual) loop 14897 if Is_By_Copy_Type (Etype (Actual)) then 14898 -- Generate: 14899 -- Jnn : aliased <formal-type> 14900 14901 Temp_Nam := Make_Temporary (Loc, 'J'); 14902 14903 Append_To (Decls, 14904 Make_Object_Declaration (Loc, 14905 Aliased_Present => True, 14906 Defining_Identifier => Temp_Nam, 14907 Object_Definition => 14908 New_Occurrence_Of (Etype (Formal), Loc))); 14909 14910 -- The object is initialized with an explicit assignment 14911 -- later. Indicate that it does not need an initialization 14912 -- to prevent spurious warnings if the type excludes null. 14913 14914 Set_No_Initialization (Last (Decls)); 14915 14916 if Ekind (Formal) /= E_Out_Parameter then 14917 14918 -- Generate: 14919 -- Jnn := <actual> 14920 14921 Temp_Asn := 14922 New_Occurrence_Of (Temp_Nam, Loc); 14923 14924 Set_Assignment_OK (Temp_Asn); 14925 14926 Append_To (Stmts, 14927 Make_Assignment_Statement (Loc, 14928 Name => Temp_Asn, 14929 Expression => New_Copy_Tree (Actual))); 14930 end if; 14931 14932 -- If the actual is not controlling, generate: 14933 14934 -- Jnn'unchecked_access 14935 14936 -- and add it to aggegate for access to formals. Note that the 14937 -- actual may be by-copy but still be a controlling actual if it 14938 -- is an access to class-wide interface. 14939 14940 if not Is_Controlling_Actual (Actual) then 14941 Append_To (Params, 14942 Make_Attribute_Reference (Loc, 14943 Attribute_Name => Name_Unchecked_Access, 14944 Prefix => New_Occurrence_Of (Temp_Nam, Loc))); 14945 14946 Has_Param := True; 14947 end if; 14948 14949 -- The controlling parameter is omitted 14950 14951 else 14952 if not Is_Controlling_Actual (Actual) then 14953 Append_To (Params, 14954 Make_Reference (Loc, New_Copy_Tree (Actual))); 14955 14956 Has_Param := True; 14957 end if; 14958 end if; 14959 14960 Next_Actual (Actual); 14961 Next_Formal_With_Extras (Formal); 14962 end loop; 14963 14964 if Has_Param then 14965 Expr := Make_Aggregate (Loc, Params); 14966 end if; 14967 14968 -- Generate: 14969 -- P : Ann := ( 14970 -- J1'unchecked_access; 14971 -- <actual2>'reference; 14972 -- ...); 14973 14974 P := Make_Temporary (Loc, 'P'); 14975 14976 Append_To (Decls, 14977 Make_Object_Declaration (Loc, 14978 Defining_Identifier => P, 14979 Object_Definition => New_Occurrence_Of (Blk_Typ, Loc), 14980 Expression => Expr)); 14981 14982 return P; 14983 end Parameter_Block_Pack; 14984 14985 ---------------------------- 14986 -- Parameter_Block_Unpack -- 14987 ---------------------------- 14988 14989 function Parameter_Block_Unpack 14990 (Loc : Source_Ptr; 14991 P : Entity_Id; 14992 Actuals : List_Id; 14993 Formals : List_Id) return List_Id 14994 is 14995 Actual : Entity_Id; 14996 Asnmt : Node_Id; 14997 Formal : Entity_Id; 14998 Has_Asnmt : Boolean := False; 14999 Result : constant List_Id := New_List; 15000 15001 begin 15002 Actual := First (Actuals); 15003 Formal := Defining_Identifier (First (Formals)); 15004 while Present (Actual) loop 15005 if Is_By_Copy_Type (Etype (Actual)) 15006 and then Ekind (Formal) /= E_In_Parameter 15007 then 15008 -- Generate: 15009 -- <actual> := P.<formal>; 15010 15011 Asnmt := 15012 Make_Assignment_Statement (Loc, 15013 Name => 15014 New_Copy (Actual), 15015 Expression => 15016 Make_Explicit_Dereference (Loc, 15017 Make_Selected_Component (Loc, 15018 Prefix => 15019 New_Occurrence_Of (P, Loc), 15020 Selector_Name => 15021 Make_Identifier (Loc, Chars (Formal))))); 15022 15023 Set_Assignment_OK (Name (Asnmt)); 15024 Append_To (Result, Asnmt); 15025 15026 Has_Asnmt := True; 15027 end if; 15028 15029 Next_Actual (Actual); 15030 Next_Formal_With_Extras (Formal); 15031 end loop; 15032 15033 if Has_Asnmt then 15034 return Result; 15035 else 15036 return New_List (Make_Null_Statement (Loc)); 15037 end if; 15038 end Parameter_Block_Unpack; 15039 15040 --------------------- 15041 -- Reset_Scopes_To -- 15042 --------------------- 15043 15044 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is 15045 function Reset_Scope (N : Node_Id) return Traverse_Result; 15046 -- Temporaries may have been declared during expansion of the procedure 15047 -- created for an entry body or an accept alternative. Indicate that 15048 -- their scope is the new body, to ensure proper generation of uplevel 15049 -- references where needed during unnesting. 15050 15051 procedure Reset_Scopes is new Traverse_Proc (Reset_Scope); 15052 15053 ----------------- 15054 -- Reset_Scope -- 15055 ----------------- 15056 15057 function Reset_Scope (N : Node_Id) return Traverse_Result is 15058 Decl : Node_Id; 15059 15060 begin 15061 -- If this is a block statement with an Identifier, it forms a scope, 15062 -- so we want to reset its scope but not look inside. 15063 15064 if N /= Bod 15065 and then Nkind (N) = N_Block_Statement 15066 and then Present (Identifier (N)) 15067 then 15068 Set_Scope (Entity (Identifier (N)), E); 15069 return Skip; 15070 15071 -- Ditto for a package declaration or a full type declaration, etc. 15072 15073 elsif (Nkind (N) = N_Package_Declaration 15074 and then N /= Specification (N)) 15075 or else Nkind (N) in N_Declaration 15076 or else Nkind (N) in N_Renaming_Declaration 15077 then 15078 Set_Scope (Defining_Entity (N), E); 15079 return Skip; 15080 15081 elsif N = Bod then 15082 15083 -- Scan declarations in new body. Declarations in the statement 15084 -- part will be handled during later traversal. 15085 15086 Decl := First (Declarations (N)); 15087 while Present (Decl) loop 15088 Reset_Scopes (Decl); 15089 Next (Decl); 15090 end loop; 15091 15092 elsif Nkind (N) = N_Freeze_Entity then 15093 15094 -- Scan the actions associated with a freeze node, which may 15095 -- actually be declarations with entities that need to have 15096 -- their scopes reset. 15097 15098 Decl := First (Actions (N)); 15099 while Present (Decl) loop 15100 Reset_Scopes (Decl); 15101 Next (Decl); 15102 end loop; 15103 15104 elsif N /= Bod and then Nkind (N) in N_Proper_Body then 15105 15106 -- A subprogram without a separate declaration may be encountered, 15107 -- and we need to reset the subprogram's entity's scope. 15108 15109 if Nkind (N) = N_Subprogram_Body then 15110 Set_Scope (Defining_Entity (Specification (N)), E); 15111 end if; 15112 15113 return Skip; 15114 end if; 15115 15116 return OK; 15117 end Reset_Scope; 15118 15119 -- Start of processing for Reset_Scopes_To 15120 15121 begin 15122 Reset_Scopes (Bod); 15123 end Reset_Scopes_To; 15124 15125 ---------------------- 15126 -- Set_Discriminals -- 15127 ---------------------- 15128 15129 procedure Set_Discriminals (Dec : Node_Id) is 15130 D : Entity_Id; 15131 Pdef : Entity_Id; 15132 D_Minal : Entity_Id; 15133 15134 begin 15135 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); 15136 Pdef := Defining_Identifier (Dec); 15137 15138 if Has_Discriminants (Pdef) then 15139 D := First_Discriminant (Pdef); 15140 while Present (D) loop 15141 D_Minal := 15142 Make_Defining_Identifier (Sloc (D), 15143 Chars => New_External_Name (Chars (D), 'D')); 15144 15145 Set_Ekind (D_Minal, E_Constant); 15146 Set_Etype (D_Minal, Etype (D)); 15147 Set_Scope (D_Minal, Pdef); 15148 Set_Discriminal (D, D_Minal); 15149 Set_Discriminal_Link (D_Minal, D); 15150 15151 Next_Discriminant (D); 15152 end loop; 15153 end if; 15154 end Set_Discriminals; 15155 15156 ----------------------- 15157 -- Trivial_Accept_OK -- 15158 ----------------------- 15159 15160 function Trivial_Accept_OK return Boolean is 15161 begin 15162 case Opt.Task_Dispatching_Policy is 15163 15164 -- If we have the default task dispatching policy in effect, we can 15165 -- definitely do the optimization (one way of looking at this is to 15166 -- think of the formal definition of the default policy being allowed 15167 -- to run any task it likes after a rendezvous, so even if notionally 15168 -- a full rescheduling occurs, we can say that our dispatching policy 15169 -- (i.e. the default dispatching policy) reorders the queue to be the 15170 -- same as just before the call. 15171 15172 when ' ' => 15173 return True; 15174 15175 -- FIFO_Within_Priorities certainly does not permit this 15176 -- optimization since the Rendezvous is a scheduling action that may 15177 -- require some other task to be run. 15178 15179 when 'F' => 15180 return False; 15181 15182 -- For now, disallow the optimization for all other policies. This 15183 -- may be over-conservative, but it is certainly not incorrect. 15184 15185 when others => 15186 return False; 15187 end case; 15188 end Trivial_Accept_OK; 15189 15190end Exp_Ch9; 15191