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-2019, 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 Aspects; use Aspects; 27with Atree; use Atree; 28with Einfo; use Einfo; 29with Elists; use Elists; 30with Errout; use Errout; 31with Exp_Ch3; use Exp_Ch3; 32with Exp_Ch6; use Exp_Ch6; 33with Exp_Ch11; use Exp_Ch11; 34with Exp_Dbug; use Exp_Dbug; 35with Exp_Sel; use Exp_Sel; 36with Exp_Smem; use Exp_Smem; 37with Exp_Tss; use Exp_Tss; 38with Exp_Util; use Exp_Util; 39with Freeze; use Freeze; 40with Hostparm; 41with Itypes; use Itypes; 42with Namet; use Namet; 43with Nlists; use Nlists; 44with Nmake; use Nmake; 45with Opt; use Opt; 46with Restrict; use Restrict; 47with Rident; use Rident; 48with Rtsfind; use Rtsfind; 49with Sem; use Sem; 50with Sem_Aux; use Sem_Aux; 51with Sem_Ch6; use Sem_Ch6; 52with Sem_Ch8; use Sem_Ch8; 53with Sem_Ch9; use Sem_Ch9; 54with Sem_Ch11; use Sem_Ch11; 55with Sem_Elab; use Sem_Elab; 56with Sem_Eval; use Sem_Eval; 57with Sem_Prag; use Sem_Prag; 58with Sem_Res; use Sem_Res; 59with Sem_Util; use Sem_Util; 60with Sinfo; use Sinfo; 61with Snames; use Snames; 62with Stand; use Stand; 63with Targparm; use Targparm; 64with Tbuild; use Tbuild; 65with Uintp; use Uintp; 66with Validsw; use Validsw; 67 68package body Exp_Ch9 is 69 70 -- The following constant establishes the upper bound for the index of 71 -- an entry family. It is used to limit the allocated size of protected 72 -- types with defaulted discriminant of an integer type, when the bound 73 -- of some entry family depends on a discriminant. The limitation to entry 74 -- families of 128K should be reasonable in all cases, and is a documented 75 -- implementation restriction. 76 77 Entry_Family_Bound : constant Pos := 2**16; 78 79 ----------------------- 80 -- Local Subprograms -- 81 ----------------------- 82 83 function Actual_Index_Expression 84 (Sloc : Source_Ptr; 85 Ent : Entity_Id; 86 Index : Node_Id; 87 Tsk : Entity_Id) return Node_Id; 88 -- Compute the index position for an entry call. Tsk is the target task. If 89 -- the bounds of some entry family depend on discriminants, the expression 90 -- computed by this function uses the discriminants of the target task. 91 92 procedure Add_Object_Pointer 93 (Loc : Source_Ptr; 94 Conc_Typ : Entity_Id; 95 Decls : List_Id); 96 -- Prepend an object pointer declaration to the declaration list Decls. 97 -- This object pointer is initialized to a type conversion of the System. 98 -- Address pointer passed to entry barrier functions and entry body 99 -- procedures. 100 101 procedure Add_Formal_Renamings 102 (Spec : Node_Id; 103 Decls : List_Id; 104 Ent : Entity_Id; 105 Loc : Source_Ptr); 106 -- Create renaming declarations for the formals, inside the procedure that 107 -- implements an entry body. The renamings make the original names of the 108 -- formals accessible to gdb, and serve no other purpose. 109 -- Spec is the specification of the procedure being built. 110 -- Decls is the list of declarations to be enhanced. 111 -- Ent is the entity for the original entry body. 112 113 function Build_Accept_Body (Astat : Node_Id) return Node_Id; 114 -- Transform accept statement into a block with added exception handler. 115 -- Used both for simple accept statements and for accept alternatives in 116 -- select statements. Astat is the accept statement. 117 118 function Build_Barrier_Function 119 (N : Node_Id; 120 Ent : Entity_Id; 121 Pid : Node_Id) return Node_Id; 122 -- Build the function body returning the value of the barrier expression 123 -- for the specified entry body. 124 125 function Build_Barrier_Function_Specification 126 (Loc : Source_Ptr; 127 Def_Id : Entity_Id) return Node_Id; 128 -- Build a specification for a function implementing the protected entry 129 -- barrier of the specified entry body. 130 131 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id); 132 -- Build the body of a wrapper procedure for an entry or entry family that 133 -- has contract cases, preconditions, or postconditions. The body gathers 134 -- the executable contract items and expands them in the usual way, and 135 -- performs the entry call itself. This way preconditions are evaluated 136 -- before the call is queued. E is the entry in question, and Decl is the 137 -- enclosing synchronized type declaration at whose freeze point the 138 -- generated body is analyzed. 139 140 function Build_Corresponding_Record 141 (N : Node_Id; 142 Ctyp : Node_Id; 143 Loc : Source_Ptr) return Node_Id; 144 -- Common to tasks and protected types. Copy discriminant specifications, 145 -- build record declaration. N is the type declaration, Ctyp is the 146 -- concurrent entity (task type or protected type). 147 148 function Build_Dispatching_Tag_Check 149 (K : Entity_Id; 150 N : Node_Id) return Node_Id; 151 -- Utility to create the tree to check whether the dispatching call in 152 -- a timed entry call, a conditional entry call, or an asynchronous 153 -- transfer of control is a call to a primitive of a non-synchronized type. 154 -- K is the temporary that holds the tagged kind of the target object, and 155 -- N is the enclosing construct. 156 157 function Build_Entry_Count_Expression 158 (Concurrent_Type : Node_Id; 159 Component_List : List_Id; 160 Loc : Source_Ptr) return Node_Id; 161 -- Compute number of entries for concurrent object. This is a count of 162 -- simple entries, followed by an expression that computes the length 163 -- of the range of each entry family. A single array with that size is 164 -- allocated for each concurrent object of the type. 165 166 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; 167 -- Build the function that translates the entry index in the call 168 -- (which depends on the size of entry families) into an index into the 169 -- Entry_Bodies_Array, to determine the body and barrier function used 170 -- in a protected entry call. A pointer to this function appears in every 171 -- protected object. 172 173 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id; 174 -- Build subprogram declaration for previous one 175 176 function Build_Lock_Free_Protected_Subprogram_Body 177 (N : Node_Id; 178 Prot_Typ : Node_Id; 179 Unprot_Spec : Node_Id) return Node_Id; 180 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is 181 -- the subprogram specification of the unprotected version of N. Transform 182 -- N such that it invokes the unprotected version of the body. 183 184 function Build_Lock_Free_Unprotected_Subprogram_Body 185 (N : Node_Id; 186 Prot_Typ : Node_Id) return Node_Id; 187 -- N denotes a subprogram body of protected type Prot_Typ. Build a version 188 -- of N where the original statements of N are synchronized through atomic 189 -- actions such as compare and exchange. Prior to invoking this routine, it 190 -- has been established that N can be implemented in a lock-free fashion. 191 192 function Build_Parameter_Block 193 (Loc : Source_Ptr; 194 Actuals : List_Id; 195 Formals : List_Id; 196 Decls : List_Id) return Entity_Id; 197 -- Generate an access type for each actual parameter in the list Actuals. 198 -- Create an encapsulating record that contains all the actuals and return 199 -- its type. Generate: 200 -- type Ann1 is access all <actual1-type> 201 -- ... 202 -- type AnnN is access all <actualN-type> 203 -- type Pnn is record 204 -- <formal1> : Ann1; 205 -- ... 206 -- <formalN> : AnnN; 207 -- end record; 208 209 function Build_Protected_Entry 210 (N : Node_Id; 211 Ent : Entity_Id; 212 Pid : Node_Id) return Node_Id; 213 -- Build the procedure implementing the statement sequence of the specified 214 -- entry body. 215 216 function Build_Protected_Entry_Specification 217 (Loc : Source_Ptr; 218 Def_Id : Entity_Id; 219 Ent_Id : Entity_Id) return Node_Id; 220 -- Build a specification for the procedure implementing the statements of 221 -- the specified entry body. Add attributes associating it with the entry 222 -- defining identifier Ent_Id. 223 224 function Build_Protected_Spec 225 (N : Node_Id; 226 Obj_Type : Entity_Id; 227 Ident : Entity_Id; 228 Unprotected : Boolean := False) return List_Id; 229 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_ 230 -- Subprogram_Type. Builds signature of protected subprogram, adding the 231 -- formal that corresponds to the object itself. For an access to protected 232 -- subprogram, there is no object type to specify, so the parameter has 233 -- type Address and mode In. An indirect call through such a pointer will 234 -- convert the address to a reference to the actual object. The object is 235 -- a limited record and therefore a by_reference type. 236 237 function Build_Protected_Subprogram_Body 238 (N : Node_Id; 239 Pid : Node_Id; 240 N_Op_Spec : Node_Id) return Node_Id; 241 -- This function is used to construct the protected version of a protected 242 -- subprogram. Its statement sequence first defers abort, then locks the 243 -- associated protected object, and then enters a block that contains a 244 -- call to the unprotected version of the subprogram (for details, see 245 -- Build_Unprotected_Subprogram_Body). This block statement requires a 246 -- cleanup handler that unlocks the object in all cases. For details, 247 -- see Exp_Ch7.Expand_Cleanup_Actions. 248 249 function Build_Renamed_Formal_Declaration 250 (New_F : Entity_Id; 251 Formal : Entity_Id; 252 Comp : Entity_Id; 253 Renamed_Formal : Node_Id) return Node_Id; 254 -- Create a renaming declaration for a formal, within a protected entry 255 -- body or an accept body. The renamed object is a component of the 256 -- parameter block that is a parameter in the entry call. 257 -- 258 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming 259 -- does not dereference the corresponding component to prevent an illegal 260 -- use of the incomplete type (AI05-0151). 261 262 function Build_Selected_Name 263 (Prefix : Entity_Id; 264 Selector : Entity_Id; 265 Append_Char : Character := ' ') return Name_Id; 266 -- Build a name in the form of Prefix__Selector, with an optional character 267 -- appended. This is used for internal subprograms generated for operations 268 -- of protected types, including barrier functions. For the subprograms 269 -- generated for entry bodies and entry barriers, the generated name 270 -- includes a sequence number that makes names unique in the presence of 271 -- entry overloading. This is necessary because entry body procedures and 272 -- barrier functions all have the same signature. 273 274 procedure Build_Simple_Entry_Call 275 (N : Node_Id; 276 Concval : Node_Id; 277 Ename : Node_Id; 278 Index : Node_Id); 279 -- Some comments here would be useful ??? 280 281 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id; 282 -- This routine constructs a specification for the procedure that we will 283 -- build for the task body for task type T. The spec has the form: 284 -- 285 -- procedure tnameB (_Task : access tnameV); 286 -- 287 -- where name is the character name taken from the task type entity that 288 -- is passed as the argument to the procedure, and tnameV is the task 289 -- value type that is associated with the task type. 290 291 function Build_Unprotected_Subprogram_Body 292 (N : Node_Id; 293 Pid : Node_Id) return Node_Id; 294 -- This routine constructs the unprotected version of a protected 295 -- subprogram body, which contains all of the code in the original, 296 -- unexpanded body. This is the version of the protected subprogram that is 297 -- called from all protected operations on the same object, including the 298 -- protected version of the same subprogram. 299 300 procedure Build_Wrapper_Bodies 301 (Loc : Source_Ptr; 302 Typ : Entity_Id; 303 N : Node_Id); 304 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding 305 -- record of a concurrent type. N is the insertion node where all bodies 306 -- will be placed. This routine builds the bodies of the subprograms which 307 -- serve as an indirection mechanism to overriding primitives of concurrent 308 -- types, entries and protected procedures. Any new body is analyzed. 309 310 procedure Build_Wrapper_Specs 311 (Loc : Source_Ptr; 312 Typ : Entity_Id; 313 N : in out Node_Id); 314 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding 315 -- record of a concurrent type. N is the insertion node where all specs 316 -- will be placed. This routine builds the specs of the subprograms which 317 -- serve as an indirection mechanism to overriding primitives of concurrent 318 -- types, entries and protected procedures. Any new spec is analyzed. 319 320 procedure Collect_Entry_Families 321 (Loc : Source_Ptr; 322 Cdecls : List_Id; 323 Current_Node : in out Node_Id; 324 Conctyp : Entity_Id); 325 -- For each entry family in a concurrent type, create an anonymous array 326 -- type of the right size, and add a component to the corresponding_record. 327 328 function Concurrent_Object 329 (Spec_Id : Entity_Id; 330 Conc_Typ : Entity_Id) return Entity_Id; 331 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return 332 -- the entity associated with the concurrent object in the Protected_Body_ 333 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity 334 -- denotes formal parameter _O, _object or _task. 335 336 function Copy_Result_Type (Res : Node_Id) return Node_Id; 337 -- Copy the result type of a function specification, when building the 338 -- internal operation corresponding to a protected function, or when 339 -- expanding an access to protected function. If the result is an anonymous 340 -- access to subprogram itself, we need to create a new signature with the 341 -- same parameter names and the same resolved types, but with new entities 342 -- for the formals. 343 344 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean; 345 -- Return whether a secondary stack for the task T should be created by the 346 -- expander. The secondary stack for a task will be created by the expander 347 -- if the size of the stack has been specified by the Secondary_Stack_Size 348 -- representation aspect and either the No_Implicit_Heap_Allocations or 349 -- No_Implicit_Task_Allocations restrictions are in effect and the 350 -- No_Secondary_Stack restriction is not. 351 352 procedure Debug_Private_Data_Declarations (Decls : List_Id); 353 -- Decls is a list which may contain the declarations created by Install_ 354 -- Private_Data_Declarations. All generated entities are marked as needing 355 -- debug info and debug nodes are manually generation where necessary. This 356 -- step of the expansion must to be done after private data has been moved 357 -- to its final resting scope to ensure proper visibility of debug objects. 358 359 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id); 360 -- If control flow optimizations are suppressed, and Alt is an accept, 361 -- delay, or entry call alternative with no trailing statements, insert 362 -- a null trailing statement with the given Loc (which is the sloc of 363 -- the accept, delay, or entry call statement). There might not be any 364 -- generated code for the accept, delay, or entry call itself (the effect 365 -- of these statements is part of the general processsing done for the 366 -- enclosing selective accept, timed entry call, or asynchronous select), 367 -- and the null statement is there to carry the sloc of that statement to 368 -- the back-end for trace-based coverage analysis purposes. 369 370 procedure Extract_Dispatching_Call 371 (N : Node_Id; 372 Call_Ent : out Entity_Id; 373 Object : out Entity_Id; 374 Actuals : out List_Id; 375 Formals : out List_Id); 376 -- Given a dispatching call, extract the entity of the name of the call, 377 -- its actual dispatching object, its actual parameters and the formal 378 -- parameters of the overridden interface-level version. If the type of 379 -- the dispatching object is an access type then an explicit dereference 380 -- is returned in Object. 381 382 procedure Extract_Entry 383 (N : Node_Id; 384 Concval : out Node_Id; 385 Ename : out Node_Id; 386 Index : out Node_Id); 387 -- Given an entry call, returns the associated concurrent object, the entry 388 -- name, and the entry family index. 389 390 function Family_Offset 391 (Loc : Source_Ptr; 392 Hi : Node_Id; 393 Lo : Node_Id; 394 Ttyp : Entity_Id; 395 Cap : Boolean) return Node_Id; 396 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an 397 -- accept statement, or the upper bound in the discrete subtype of an entry 398 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent 399 -- type of the entry. If Cap is true, the result is capped according to 400 -- Entry_Family_Bound. 401 402 function Family_Size 403 (Loc : Source_Ptr; 404 Hi : Node_Id; 405 Lo : Node_Id; 406 Ttyp : Entity_Id; 407 Cap : Boolean) return Node_Id; 408 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a 409 -- family, and handle properly the superflat case. This is equivalent to 410 -- the use of 'Length on the index type, but must use Family_Offset to 411 -- handle properly the case of bounds that depend on discriminants. If 412 -- Cap is true, the result is capped according to Entry_Family_Bound. 413 414 procedure Find_Enclosing_Context 415 (N : Node_Id; 416 Context : out Node_Id; 417 Context_Id : out Entity_Id; 418 Context_Decls : out List_Id); 419 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and 420 -- Build_Master_Entity. Given an arbitrary node in the tree, find the 421 -- nearest enclosing body, block, package, or return statement and return 422 -- its constituents. Context is the enclosing construct, Context_Id is 423 -- the scope of Context_Id and Context_Decls is the declarative list of 424 -- Context. 425 426 function Index_Object (Spec_Id : Entity_Id) return Entity_Id; 427 -- Given a subprogram identifier, return the entity which is associated 428 -- with the protection entry index in the Protected_Body_Subprogram or 429 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal 430 -- parameter _E. 431 432 function Is_Potentially_Large_Family 433 (Base_Index : Entity_Id; 434 Conctyp : Entity_Id; 435 Lo : Node_Id; 436 Hi : Node_Id) return Boolean; 437 438 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean; 439 -- Determine whether Id is a function or a procedure and is marked as a 440 -- private primitive. 441 442 function Null_Statements (Stats : List_Id) return Boolean; 443 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. 444 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well 445 -- to still count as null. Returns True for a null sequence. The argument 446 -- is the list of statements from the DO-END sequence. 447 448 function Parameter_Block_Pack 449 (Loc : Source_Ptr; 450 Blk_Typ : Entity_Id; 451 Actuals : List_Id; 452 Formals : List_Id; 453 Decls : List_Id; 454 Stmts : List_Id) return Entity_Id; 455 -- Set the components of the generated parameter block with the values 456 -- of the actual parameters. Generate aliased temporaries to capture the 457 -- values for types that are passed by copy. Otherwise generate a reference 458 -- to the actual's value. Return the address of the aggregate block. 459 -- Generate: 460 -- Jnn1 : alias <formal-type1>; 461 -- Jnn1 := <actual1>; 462 -- ... 463 -- P : Blk_Typ := ( 464 -- Jnn1'unchecked_access; 465 -- <actual2>'reference; 466 -- ...); 467 468 function Parameter_Block_Unpack 469 (Loc : Source_Ptr; 470 P : Entity_Id; 471 Actuals : List_Id; 472 Formals : List_Id) return List_Id; 473 -- Retrieve the values of the components from the parameter block and 474 -- assign then to the original actual parameters. Generate: 475 -- <actual1> := P.<formal1>; 476 -- ... 477 -- <actualN> := P.<formalN>; 478 479 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id); 480 -- Reset the scope of declarations and blocks at the top level of Bod 481 -- to be E. Bod is either a block or a subprogram body. Used after 482 -- expanding various kinds of entry bodies into their corresponding 483 -- constructs. This is needed during unnesting to determine whether a 484 -- body generated for an entry or an accept alternative includes uplevel 485 -- references. 486 487 function Trivial_Accept_OK return Boolean; 488 -- If there is no DO-END block for an accept, or if the DO-END block has 489 -- only null statements, then it is possible to do the Rendezvous with much 490 -- less overhead using the Accept_Trivial routine in the run-time library. 491 -- However, this is not always a valid optimization. Whether it is valid or 492 -- not depends on the Task_Dispatching_Policy. The issue is whether a full 493 -- rescheduling action is required or not. In FIFO_Within_Priorities, such 494 -- a rescheduling is required, so this optimization is not allowed. This 495 -- function returns True if the optimization is permitted. 496 497 ----------------------------- 498 -- Actual_Index_Expression -- 499 ----------------------------- 500 501 function Actual_Index_Expression 502 (Sloc : Source_Ptr; 503 Ent : Entity_Id; 504 Index : Node_Id; 505 Tsk : Entity_Id) return Node_Id 506 is 507 Ttyp : constant Entity_Id := Etype (Tsk); 508 Expr : Node_Id; 509 Num : Node_Id; 510 Lo : Node_Id; 511 Hi : Node_Id; 512 Prev : Entity_Id; 513 S : Node_Id; 514 515 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id; 516 -- Compute difference between bounds of entry family 517 518 -------------------------- 519 -- Actual_Family_Offset -- 520 -------------------------- 521 522 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is 523 524 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; 525 -- Replace a reference to a discriminant with a selected component 526 -- denoting the discriminant of the target task. 527 528 ----------------------------- 529 -- Actual_Discriminant_Ref -- 530 ----------------------------- 531 532 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is 533 Typ : constant Entity_Id := Etype (Bound); 534 B : Node_Id; 535 536 begin 537 if not Is_Entity_Name (Bound) 538 or else Ekind (Entity (Bound)) /= E_Discriminant 539 then 540 if Nkind (Bound) = N_Attribute_Reference then 541 return Bound; 542 else 543 B := New_Copy_Tree (Bound); 544 end if; 545 546 else 547 B := 548 Make_Selected_Component (Sloc, 549 Prefix => New_Copy_Tree (Tsk), 550 Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc)); 551 552 Analyze_And_Resolve (B, Typ); 553 end if; 554 555 return 556 Make_Attribute_Reference (Sloc, 557 Attribute_Name => Name_Pos, 558 Prefix => New_Occurrence_Of (Etype (Bound), Sloc), 559 Expressions => New_List (B)); 560 end Actual_Discriminant_Ref; 561 562 -- Start of processing for Actual_Family_Offset 563 564 begin 565 return 566 Make_Op_Subtract (Sloc, 567 Left_Opnd => Actual_Discriminant_Ref (Hi), 568 Right_Opnd => Actual_Discriminant_Ref (Lo)); 569 end Actual_Family_Offset; 570 571 -- Start of processing for Actual_Index_Expression 572 573 begin 574 -- The queues of entries and entry families appear in textual order in 575 -- the associated record. The entry index is computed as the sum of the 576 -- number of queues for all entries that precede the designated one, to 577 -- which is added the index expression, if this expression denotes a 578 -- member of a family. 579 580 -- The following is a place holder for the count of simple entries 581 582 Num := Make_Integer_Literal (Sloc, 1); 583 584 -- We construct an expression which is a series of addition operations. 585 -- See comments in Entry_Index_Expression, which is identical in 586 -- structure. 587 588 if Present (Index) then 589 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); 590 591 Expr := 592 Make_Op_Add (Sloc, 593 Left_Opnd => Num, 594 Right_Opnd => 595 Actual_Family_Offset ( 596 Make_Attribute_Reference (Sloc, 597 Attribute_Name => Name_Pos, 598 Prefix => New_Occurrence_Of (Base_Type (S), Sloc), 599 Expressions => New_List (Relocate_Node (Index))), 600 Type_Low_Bound (S))); 601 else 602 Expr := Num; 603 end if; 604 605 -- Now add lengths of preceding entries and entry families 606 607 Prev := First_Entity (Ttyp); 608 while Chars (Prev) /= Chars (Ent) 609 or else (Ekind (Prev) /= Ekind (Ent)) 610 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 611 loop 612 if Ekind (Prev) = E_Entry then 613 Set_Intval (Num, Intval (Num) + 1); 614 615 elsif Ekind (Prev) = E_Entry_Family then 616 S := 617 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 618 619 -- The need for the following full view retrieval stems from this 620 -- complex case of nested generics and tasking: 621 622 -- generic 623 -- type Formal_Index is range <>; 624 -- ... 625 -- package Outer is 626 -- type Index is private; 627 -- generic 628 -- ... 629 -- package Inner is 630 -- procedure P; 631 -- end Inner; 632 -- private 633 -- type Index is new Formal_Index range 1 .. 10; 634 -- end Outer; 635 636 -- package body Outer is 637 -- task type T is 638 -- entry Fam (Index); -- (2) 639 -- entry E; 640 -- end T; 641 -- package body Inner is -- (3) 642 -- procedure P is 643 -- begin 644 -- T.E; -- (1) 645 -- end P; 646 -- end Inner; 647 -- ... 648 649 -- We are currently building the index expression for the entry 650 -- call "T.E" (1). Part of the expansion must mention the range 651 -- of the discrete type "Index" (2) of entry family "Fam". 652 653 -- However only the private view of type "Index" is available to 654 -- the inner generic (3) because there was no prior mention of 655 -- the type inside "Inner". This visibility requirement is 656 -- implicit and cannot be detected during the construction of 657 -- the generic trees and needs special handling. 658 659 if In_Instance_Body 660 and then Is_Private_Type (S) 661 and then Present (Full_View (S)) 662 then 663 S := Full_View (S); 664 end if; 665 666 Lo := Type_Low_Bound (S); 667 Hi := Type_High_Bound (S); 668 669 Expr := 670 Make_Op_Add (Sloc, 671 Left_Opnd => Expr, 672 Right_Opnd => 673 Make_Op_Add (Sloc, 674 Left_Opnd => Actual_Family_Offset (Hi, Lo), 675 Right_Opnd => Make_Integer_Literal (Sloc, 1))); 676 677 -- Other components are anonymous types to be ignored 678 679 else 680 null; 681 end if; 682 683 Next_Entity (Prev); 684 end loop; 685 686 return Expr; 687 end Actual_Index_Expression; 688 689 -------------------------- 690 -- Add_Formal_Renamings -- 691 -------------------------- 692 693 procedure Add_Formal_Renamings 694 (Spec : Node_Id; 695 Decls : List_Id; 696 Ent : Entity_Id; 697 Loc : Source_Ptr) 698 is 699 Ptr : constant Entity_Id := 700 Defining_Identifier 701 (Next (First (Parameter_Specifications (Spec)))); 702 -- The name of the formal that holds the address of the parameter block 703 -- for the call. 704 705 Comp : Entity_Id; 706 Decl : Node_Id; 707 Formal : Entity_Id; 708 New_F : Entity_Id; 709 Renamed_Formal : Node_Id; 710 711 begin 712 Formal := First_Formal (Ent); 713 while Present (Formal) loop 714 Comp := Entry_Component (Formal); 715 New_F := 716 Make_Defining_Identifier (Sloc (Formal), 717 Chars => Chars (Formal)); 718 Set_Etype (New_F, Etype (Formal)); 719 Set_Scope (New_F, Ent); 720 721 -- Now we set debug info needed on New_F even though it does not come 722 -- from source, so that the debugger will get the right information 723 -- for these generated names. 724 725 Set_Debug_Info_Needed (New_F); 726 727 if Ekind (Formal) = E_In_Parameter then 728 Set_Ekind (New_F, E_Constant); 729 else 730 Set_Ekind (New_F, E_Variable); 731 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 732 end if; 733 734 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 735 736 Renamed_Formal := 737 Make_Selected_Component (Loc, 738 Prefix => 739 Unchecked_Convert_To (Entry_Parameters_Type (Ent), 740 Make_Identifier (Loc, Chars (Ptr))), 741 Selector_Name => New_Occurrence_Of (Comp, Loc)); 742 743 Decl := 744 Build_Renamed_Formal_Declaration 745 (New_F, Formal, Comp, Renamed_Formal); 746 747 Append (Decl, Decls); 748 Set_Renamed_Object (Formal, New_F); 749 Next_Formal (Formal); 750 end loop; 751 end Add_Formal_Renamings; 752 753 ------------------------ 754 -- Add_Object_Pointer -- 755 ------------------------ 756 757 procedure Add_Object_Pointer 758 (Loc : Source_Ptr; 759 Conc_Typ : Entity_Id; 760 Decls : List_Id) 761 is 762 Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ); 763 Decl : Node_Id; 764 Obj_Ptr : Node_Id; 765 766 begin 767 -- Create the renaming declaration for the Protection object of a 768 -- protected type. _Object is used by Complete_Entry_Body. 769 -- ??? An attempt to make this a renaming was unsuccessful. 770 771 -- Build the entity for the access type 772 773 Obj_Ptr := 774 Make_Defining_Identifier (Loc, 775 New_External_Name (Chars (Rec_Typ), 'P')); 776 777 -- Generate: 778 -- _object : poVP := poVP!O; 779 780 Decl := 781 Make_Object_Declaration (Loc, 782 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uObject), 783 Object_Definition => New_Occurrence_Of (Obj_Ptr, Loc), 784 Expression => 785 Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO))); 786 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 787 Prepend_To (Decls, Decl); 788 789 -- Generate: 790 -- type poVP is access poV; 791 792 Decl := 793 Make_Full_Type_Declaration (Loc, 794 Defining_Identifier => 795 Obj_Ptr, 796 Type_Definition => 797 Make_Access_To_Object_Definition (Loc, 798 Subtype_Indication => 799 New_Occurrence_Of (Rec_Typ, Loc))); 800 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 801 Prepend_To (Decls, Decl); 802 end Add_Object_Pointer; 803 804 ----------------------- 805 -- Build_Accept_Body -- 806 ----------------------- 807 808 function Build_Accept_Body (Astat : Node_Id) return Node_Id is 809 Loc : constant Source_Ptr := Sloc (Astat); 810 Stats : constant Node_Id := Handled_Statement_Sequence (Astat); 811 New_S : Node_Id; 812 Hand : Node_Id; 813 Call : Node_Id; 814 Ohandle : Node_Id; 815 816 begin 817 -- At the end of the statement sequence, Complete_Rendezvous is called. 818 -- A label skipping the Complete_Rendezvous, and all other accept 819 -- processing, has already been added for the expansion of requeue 820 -- statements. The Sloc is copied from the last statement since it 821 -- is really part of this last statement. 822 823 Call := 824 Build_Runtime_Call 825 (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous); 826 Insert_Before (Last (Statements (Stats)), Call); 827 Analyze (Call); 828 829 -- If exception handlers are present, then append Complete_Rendezvous 830 -- calls to the handlers, and construct the required outer block. As 831 -- above, the Sloc is copied from the last statement in the sequence. 832 833 if Present (Exception_Handlers (Stats)) then 834 Hand := First (Exception_Handlers (Stats)); 835 while Present (Hand) loop 836 Call := 837 Build_Runtime_Call 838 (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous); 839 Append (Call, Statements (Hand)); 840 Analyze (Call); 841 Next (Hand); 842 end loop; 843 844 New_S := 845 Make_Handled_Sequence_Of_Statements (Loc, 846 Statements => New_List ( 847 Make_Block_Statement (Loc, 848 Handled_Statement_Sequence => Stats))); 849 850 else 851 New_S := Stats; 852 end if; 853 854 -- At this stage we know that the new statement sequence does 855 -- not have an exception handler part, so we supply one to call 856 -- Exceptional_Complete_Rendezvous. This handler is 857 858 -- when all others => 859 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 860 861 -- We handle Abort_Signal to make sure that we properly catch the abort 862 -- case and wake up the caller. 863 864 Ohandle := Make_Others_Choice (Loc); 865 Set_All_Others (Ohandle); 866 867 Set_Exception_Handlers (New_S, 868 New_List ( 869 Make_Implicit_Exception_Handler (Loc, 870 Exception_Choices => New_List (Ohandle), 871 872 Statements => New_List ( 873 Make_Procedure_Call_Statement (Sloc (Stats), 874 Name => New_Occurrence_Of ( 875 RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)), 876 Parameter_Associations => New_List ( 877 Make_Function_Call (Sloc (Stats), 878 Name => 879 New_Occurrence_Of 880 (RTE (RE_Get_GNAT_Exception), Sloc (Stats))))))))); 881 882 Set_Parent (New_S, Astat); -- temp parent for Analyze call 883 Analyze_Exception_Handlers (Exception_Handlers (New_S)); 884 Expand_Exception_Handlers (New_S); 885 886 -- Exceptional_Complete_Rendezvous must be called with abort still 887 -- deferred, which is the case for a "when all others" handler. 888 889 return New_S; 890 end Build_Accept_Body; 891 892 ----------------------------------- 893 -- Build_Activation_Chain_Entity -- 894 ----------------------------------- 895 896 procedure Build_Activation_Chain_Entity (N : Node_Id) is 897 function Has_Activation_Chain (Stmt : Node_Id) return Boolean; 898 -- Determine whether an extended return statement has activation chain 899 900 -------------------------- 901 -- Has_Activation_Chain -- 902 -------------------------- 903 904 function Has_Activation_Chain (Stmt : Node_Id) return Boolean is 905 Decl : Node_Id; 906 907 begin 908 Decl := First (Return_Object_Declarations (Stmt)); 909 while Present (Decl) loop 910 if Nkind (Decl) = N_Object_Declaration 911 and then Chars (Defining_Identifier (Decl)) = Name_uChain 912 then 913 return True; 914 end if; 915 916 Next (Decl); 917 end loop; 918 919 return False; 920 end Has_Activation_Chain; 921 922 -- Local variables 923 924 Context : Node_Id; 925 Context_Id : Entity_Id; 926 Decls : List_Id; 927 928 -- Start of processing for Build_Activation_Chain_Entity 929 930 begin 931 -- Activation chain is never used for sequential elaboration policy, see 932 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 933 934 if Partition_Elaboration_Policy = 'S' then 935 return; 936 end if; 937 938 Find_Enclosing_Context (N, Context, Context_Id, Decls); 939 940 -- If activation chain entity has not been declared already, create one 941 942 if Nkind (Context) = N_Extended_Return_Statement 943 or else No (Activation_Chain_Entity (Context)) 944 then 945 -- Since extended return statements do not store the entity of the 946 -- chain, examine the return object declarations to avoid creating 947 -- a duplicate. 948 949 if Nkind (Context) = N_Extended_Return_Statement 950 and then Has_Activation_Chain (Context) 951 then 952 return; 953 end if; 954 955 declare 956 Loc : constant Source_Ptr := Sloc (Context); 957 Chain : Entity_Id; 958 Decl : Node_Id; 959 960 begin 961 Chain := Make_Defining_Identifier (Sloc (N), Name_uChain); 962 963 -- Note: An extended return statement is not really a task 964 -- activator, but it does have an activation chain on which to 965 -- store the tasks temporarily. On successful return, the tasks 966 -- on this chain are moved to the chain passed in by the caller. 967 -- We do not build an Activation_Chain_Entity for an extended 968 -- return statement, because we do not want to build a call to 969 -- Activate_Tasks. Task activation is the responsibility of the 970 -- caller. 971 972 if Nkind (Context) /= N_Extended_Return_Statement then 973 Set_Activation_Chain_Entity (Context, Chain); 974 end if; 975 976 Decl := 977 Make_Object_Declaration (Loc, 978 Defining_Identifier => Chain, 979 Aliased_Present => True, 980 Object_Definition => 981 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)); 982 983 Prepend_To (Decls, Decl); 984 985 -- Ensure that _chain appears in the proper scope of the context 986 987 if Context_Id /= Current_Scope then 988 Push_Scope (Context_Id); 989 Analyze (Decl); 990 Pop_Scope; 991 else 992 Analyze (Decl); 993 end if; 994 end; 995 end if; 996 end Build_Activation_Chain_Entity; 997 998 ---------------------------- 999 -- Build_Barrier_Function -- 1000 ---------------------------- 1001 1002 function Build_Barrier_Function 1003 (N : Node_Id; 1004 Ent : Entity_Id; 1005 Pid : Node_Id) return Node_Id 1006 is 1007 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); 1008 Cond : constant Node_Id := Condition (Ent_Formals); 1009 Loc : constant Source_Ptr := Sloc (Cond); 1010 Func_Id : constant Entity_Id := Barrier_Function (Ent); 1011 Op_Decls : constant List_Id := New_List; 1012 Stmt : Node_Id; 1013 Func_Body : Node_Id; 1014 1015 begin 1016 -- Add a declaration for the Protection object, renaming declarations 1017 -- for the discriminals and privals and finally a declaration for the 1018 -- entry family index (if applicable). 1019 1020 Install_Private_Data_Declarations (Sloc (N), 1021 Spec_Id => Func_Id, 1022 Conc_Typ => Pid, 1023 Body_Nod => N, 1024 Decls => Op_Decls, 1025 Barrier => True, 1026 Family => Ekind (Ent) = E_Entry_Family); 1027 1028 -- If compiling with -fpreserve-control-flow, make sure we insert an 1029 -- IF statement so that the back-end knows to generate a conditional 1030 -- branch instruction, even if the condition is just the name of a 1031 -- boolean object. Note that Expand_N_If_Statement knows to preserve 1032 -- such redundant IF statements under -fpreserve-control-flow 1033 -- (whether coming from this routine, or directly from source). 1034 1035 if Opt.Suppress_Control_Flow_Optimizations then 1036 Stmt := 1037 Make_Implicit_If_Statement (Cond, 1038 Condition => Cond, 1039 Then_Statements => New_List ( 1040 Make_Simple_Return_Statement (Loc, 1041 New_Occurrence_Of (Standard_True, Loc))), 1042 1043 Else_Statements => New_List ( 1044 Make_Simple_Return_Statement (Loc, 1045 New_Occurrence_Of (Standard_False, Loc)))); 1046 1047 else 1048 Stmt := Make_Simple_Return_Statement (Loc, Cond); 1049 end if; 1050 1051 -- Note: the condition in the barrier function needs to be properly 1052 -- processed for the C/Fortran boolean possibility, but this happens 1053 -- automatically since the return statement does this normalization. 1054 1055 Func_Body := 1056 Make_Subprogram_Body (Loc, 1057 Specification => 1058 Build_Barrier_Function_Specification (Loc, 1059 Make_Defining_Identifier (Loc, Chars (Func_Id))), 1060 Declarations => Op_Decls, 1061 Handled_Statement_Sequence => 1062 Make_Handled_Sequence_Of_Statements (Loc, 1063 Statements => New_List (Stmt))); 1064 Set_Is_Entry_Barrier_Function (Func_Body); 1065 1066 return Func_Body; 1067 end Build_Barrier_Function; 1068 1069 ------------------------------------------ 1070 -- Build_Barrier_Function_Specification -- 1071 ------------------------------------------ 1072 1073 function Build_Barrier_Function_Specification 1074 (Loc : Source_Ptr; 1075 Def_Id : Entity_Id) return Node_Id 1076 is 1077 begin 1078 Set_Debug_Info_Needed (Def_Id); 1079 1080 return 1081 Make_Function_Specification (Loc, 1082 Defining_Unit_Name => Def_Id, 1083 Parameter_Specifications => New_List ( 1084 Make_Parameter_Specification (Loc, 1085 Defining_Identifier => 1086 Make_Defining_Identifier (Loc, Name_uO), 1087 Parameter_Type => 1088 New_Occurrence_Of (RTE (RE_Address), Loc)), 1089 1090 Make_Parameter_Specification (Loc, 1091 Defining_Identifier => 1092 Make_Defining_Identifier (Loc, Name_uE), 1093 Parameter_Type => 1094 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), 1095 1096 Result_Definition => 1097 New_Occurrence_Of (Standard_Boolean, Loc)); 1098 end Build_Barrier_Function_Specification; 1099 1100 -------------------------- 1101 -- Build_Call_With_Task -- 1102 -------------------------- 1103 1104 function Build_Call_With_Task 1105 (N : Node_Id; 1106 E : Entity_Id) return Node_Id 1107 is 1108 Loc : constant Source_Ptr := Sloc (N); 1109 begin 1110 return 1111 Make_Function_Call (Loc, 1112 Name => New_Occurrence_Of (E, Loc), 1113 Parameter_Associations => New_List (Concurrent_Ref (N))); 1114 end Build_Call_With_Task; 1115 1116 ----------------------------- 1117 -- Build_Class_Wide_Master -- 1118 ----------------------------- 1119 1120 procedure Build_Class_Wide_Master (Typ : Entity_Id) is 1121 Loc : constant Source_Ptr := Sloc (Typ); 1122 Master_Decl : Node_Id; 1123 Master_Id : Entity_Id; 1124 Master_Scope : Entity_Id; 1125 Name_Id : Node_Id; 1126 Related_Node : Node_Id; 1127 Ren_Decl : Node_Id; 1128 1129 begin 1130 -- Nothing to do if there is no task hierarchy 1131 1132 if Restriction_Active (No_Task_Hierarchy) then 1133 return; 1134 end if; 1135 1136 -- Find the declaration that created the access type, which is either a 1137 -- type declaration, or an object declaration with an access definition, 1138 -- in which case the type is anonymous. 1139 1140 if Is_Itype (Typ) then 1141 Related_Node := Associated_Node_For_Itype (Typ); 1142 else 1143 Related_Node := Parent (Typ); 1144 end if; 1145 1146 Master_Scope := Find_Master_Scope (Typ); 1147 1148 -- Nothing to do if the master scope already contains a _master entity. 1149 -- The only exception to this is the following scenario: 1150 1151 -- Source_Scope 1152 -- Transient_Scope_1 1153 -- _master 1154 1155 -- Transient_Scope_2 1156 -- use of master 1157 1158 -- In this case the source scope is marked as having the master entity 1159 -- even though the actual declaration appears inside an inner scope. If 1160 -- the second transient scope requires a _master, it cannot use the one 1161 -- already declared because the entity is not visible. 1162 1163 Name_Id := Make_Identifier (Loc, Name_uMaster); 1164 Master_Decl := Empty; 1165 1166 if not Has_Master_Entity (Master_Scope) 1167 or else No (Current_Entity_In_Scope (Name_Id)) 1168 then 1169 begin 1170 Set_Has_Master_Entity (Master_Scope); 1171 1172 -- Generate: 1173 -- _master : constant Integer := Current_Master.all; 1174 1175 Master_Decl := 1176 Make_Object_Declaration (Loc, 1177 Defining_Identifier => 1178 Make_Defining_Identifier (Loc, Name_uMaster), 1179 Constant_Present => True, 1180 Object_Definition => 1181 New_Occurrence_Of (Standard_Integer, Loc), 1182 Expression => 1183 Make_Explicit_Dereference (Loc, 1184 New_Occurrence_Of (RTE (RE_Current_Master), Loc))); 1185 1186 Insert_Action (Find_Hook_Context (Related_Node), Master_Decl); 1187 Analyze (Master_Decl); 1188 1189 -- Mark the containing scope as a task master. Masters associated 1190 -- with return statements are already marked at this stage (see 1191 -- Analyze_Subprogram_Body). 1192 1193 if Ekind (Current_Scope) /= E_Return_Statement then 1194 declare 1195 Par : Node_Id := Related_Node; 1196 1197 begin 1198 while Nkind (Par) /= N_Compilation_Unit loop 1199 Par := Parent (Par); 1200 1201 -- If we fall off the top, we are at the outer level, 1202 -- and the environment task is our effective master, 1203 -- so nothing to mark. 1204 1205 if Nkind_In (Par, N_Block_Statement, 1206 N_Subprogram_Body, 1207 N_Task_Body) 1208 then 1209 Set_Is_Task_Master (Par); 1210 exit; 1211 end if; 1212 end loop; 1213 end; 1214 end if; 1215 end; 1216 end if; 1217 1218 Master_Id := 1219 Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'M')); 1220 1221 -- Generate: 1222 -- typeMnn renames _master; 1223 1224 Ren_Decl := 1225 Make_Object_Renaming_Declaration (Loc, 1226 Defining_Identifier => Master_Id, 1227 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), 1228 Name => Name_Id); 1229 1230 -- If the master is declared locally, add the renaming declaration 1231 -- immediately after it, to prevent access-before-elaboration in the 1232 -- back-end. 1233 1234 if Present (Master_Decl) then 1235 Insert_After (Master_Decl, Ren_Decl); 1236 Analyze (Ren_Decl); 1237 1238 else 1239 Insert_Action (Related_Node, Ren_Decl); 1240 end if; 1241 1242 Set_Master_Id (Typ, Master_Id); 1243 end Build_Class_Wide_Master; 1244 1245 ---------------------------- 1246 -- Build_Contract_Wrapper -- 1247 ---------------------------- 1248 1249 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id) is 1250 Conc_Typ : constant Entity_Id := Scope (E); 1251 Loc : constant Source_Ptr := Sloc (E); 1252 1253 procedure Add_Discriminant_Renamings 1254 (Obj_Id : Entity_Id; 1255 Decls : List_Id); 1256 -- Add renaming declarations for all discriminants of concurrent type 1257 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which 1258 -- represents the concurrent object. 1259 1260 procedure Add_Matching_Formals 1261 (Formals : List_Id; 1262 Actuals : in out List_Id); 1263 -- Add formal parameters that match those of entry E to list Formals. 1264 -- The routine also adds matching actuals for the new formals to list 1265 -- Actuals. 1266 1267 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id); 1268 -- Relocate pragma Prag to list To. The routine creates a new list if 1269 -- To does not exist. 1270 1271 -------------------------------- 1272 -- Add_Discriminant_Renamings -- 1273 -------------------------------- 1274 1275 procedure Add_Discriminant_Renamings 1276 (Obj_Id : Entity_Id; 1277 Decls : List_Id) 1278 is 1279 Discr : Entity_Id; 1280 1281 begin 1282 -- Inspect the discriminants of the concurrent type and generate a 1283 -- renaming for each one. 1284 1285 if Has_Discriminants (Conc_Typ) then 1286 Discr := First_Discriminant (Conc_Typ); 1287 while Present (Discr) loop 1288 Prepend_To (Decls, 1289 Make_Object_Renaming_Declaration (Loc, 1290 Defining_Identifier => 1291 Make_Defining_Identifier (Loc, Chars (Discr)), 1292 Subtype_Mark => 1293 New_Occurrence_Of (Etype (Discr), Loc), 1294 Name => 1295 Make_Selected_Component (Loc, 1296 Prefix => New_Occurrence_Of (Obj_Id, Loc), 1297 Selector_Name => 1298 Make_Identifier (Loc, Chars (Discr))))); 1299 1300 Next_Discriminant (Discr); 1301 end loop; 1302 end if; 1303 end Add_Discriminant_Renamings; 1304 1305 -------------------------- 1306 -- Add_Matching_Formals -- 1307 -------------------------- 1308 1309 procedure Add_Matching_Formals 1310 (Formals : List_Id; 1311 Actuals : in out List_Id) 1312 is 1313 Formal : Entity_Id; 1314 New_Formal : Entity_Id; 1315 1316 begin 1317 -- Inspect the formal parameters of the entry and generate a new 1318 -- matching formal with the same name for the wrapper. A reference 1319 -- to the new formal becomes an actual in the entry call. 1320 1321 Formal := First_Formal (E); 1322 while Present (Formal) loop 1323 New_Formal := Make_Defining_Identifier (Loc, Chars (Formal)); 1324 Append_To (Formals, 1325 Make_Parameter_Specification (Loc, 1326 Defining_Identifier => New_Formal, 1327 In_Present => In_Present (Parent (Formal)), 1328 Out_Present => Out_Present (Parent (Formal)), 1329 Parameter_Type => 1330 New_Occurrence_Of (Etype (Formal), Loc))); 1331 1332 if No (Actuals) then 1333 Actuals := New_List; 1334 end if; 1335 1336 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); 1337 Next_Formal (Formal); 1338 end loop; 1339 end Add_Matching_Formals; 1340 1341 --------------------- 1342 -- Transfer_Pragma -- 1343 --------------------- 1344 1345 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id) is 1346 New_Prag : Node_Id; 1347 1348 begin 1349 if No (To) then 1350 To := New_List; 1351 end if; 1352 1353 New_Prag := Relocate_Node (Prag); 1354 1355 Set_Analyzed (New_Prag, False); 1356 Append (New_Prag, To); 1357 end Transfer_Pragma; 1358 1359 -- Local variables 1360 1361 Items : constant Node_Id := Contract (E); 1362 Actuals : List_Id := No_List; 1363 Call : Node_Id; 1364 Call_Nam : Node_Id; 1365 Decls : List_Id := No_List; 1366 Formals : List_Id; 1367 Has_Pragma : Boolean := False; 1368 Index_Id : Entity_Id; 1369 Obj_Id : Entity_Id; 1370 Prag : Node_Id; 1371 Wrapper_Id : Entity_Id; 1372 1373 -- Start of processing for Build_Contract_Wrapper 1374 1375 begin 1376 -- This routine generates a specialized wrapper for a protected or task 1377 -- entry [family] which implements precondition/postcondition semantics. 1378 -- Preconditions and case guards of contract cases are checked before 1379 -- the protected action or rendezvous takes place. Postconditions and 1380 -- consequences of contract cases are checked after the protected action 1381 -- or rendezvous takes place. The structure of the generated wrapper is 1382 -- as follows: 1383 1384 -- procedure Wrapper 1385 -- (Obj_Id : Conc_Typ; -- concurrent object 1386 -- [Index : Index_Typ;] -- index of entry family 1387 -- [Formal_1 : ...; -- parameters of original entry 1388 -- Formal_N : ...]) 1389 -- is 1390 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant 1391 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings 1392 1393 -- <precondition checks> 1394 -- <case guard checks> 1395 1396 -- procedure _Postconditions is 1397 -- begin 1398 -- <postcondition checks> 1399 -- <consequence checks> 1400 -- end _Postconditions; 1401 1402 -- begin 1403 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]); 1404 -- _Postconditions; 1405 -- end Wrapper; 1406 1407 -- Create the wrapper only when the entry has at least one executable 1408 -- contract item such as contract cases, precondition or postcondition. 1409 1410 if Present (Items) then 1411 1412 -- Inspect the list of pre/postconditions and transfer all available 1413 -- pragmas to the declarative list of the wrapper. 1414 1415 Prag := Pre_Post_Conditions (Items); 1416 while Present (Prag) loop 1417 if Nam_In (Pragma_Name_Unmapped (Prag), 1418 Name_Postcondition, Name_Precondition) 1419 and then Is_Checked (Prag) 1420 then 1421 Has_Pragma := True; 1422 Transfer_Pragma (Prag, To => Decls); 1423 end if; 1424 1425 Prag := Next_Pragma (Prag); 1426 end loop; 1427 1428 -- Inspect the list of test/contract cases and transfer only contract 1429 -- cases pragmas to the declarative part of the wrapper. 1430 1431 Prag := Contract_Test_Cases (Items); 1432 while Present (Prag) loop 1433 if Pragma_Name (Prag) = Name_Contract_Cases 1434 and then Is_Checked (Prag) 1435 then 1436 Has_Pragma := True; 1437 Transfer_Pragma (Prag, To => Decls); 1438 end if; 1439 1440 Prag := Next_Pragma (Prag); 1441 end loop; 1442 end if; 1443 1444 -- The entry lacks executable contract items and a wrapper is not needed 1445 1446 if not Has_Pragma then 1447 return; 1448 end if; 1449 1450 -- Create the profile of the wrapper. The first formal parameter is the 1451 -- concurrent object. 1452 1453 Obj_Id := 1454 Make_Defining_Identifier (Loc, 1455 Chars => New_External_Name (Chars (Conc_Typ), 'A')); 1456 1457 Formals := New_List ( 1458 Make_Parameter_Specification (Loc, 1459 Defining_Identifier => Obj_Id, 1460 Out_Present => True, 1461 In_Present => True, 1462 Parameter_Type => New_Occurrence_Of (Conc_Typ, Loc))); 1463 1464 -- Construct the call to the original entry. The call will be gradually 1465 -- augmented with an optional entry index and extra parameters. 1466 1467 Call_Nam := 1468 Make_Selected_Component (Loc, 1469 Prefix => New_Occurrence_Of (Obj_Id, Loc), 1470 Selector_Name => New_Occurrence_Of (E, Loc)); 1471 1472 -- When creating a wrapper for an entry family, the second formal is the 1473 -- entry index. 1474 1475 if Ekind (E) = E_Entry_Family then 1476 Index_Id := Make_Defining_Identifier (Loc, Name_I); 1477 1478 Append_To (Formals, 1479 Make_Parameter_Specification (Loc, 1480 Defining_Identifier => Index_Id, 1481 Parameter_Type => 1482 New_Occurrence_Of (Entry_Index_Type (E), Loc))); 1483 1484 -- The call to the original entry becomes an indexed component to 1485 -- accommodate the entry index. 1486 1487 Call_Nam := 1488 Make_Indexed_Component (Loc, 1489 Prefix => Call_Nam, 1490 Expressions => New_List (New_Occurrence_Of (Index_Id, Loc))); 1491 end if; 1492 1493 -- Add formal parameters to match those of the entry and build actuals 1494 -- for the entry call. 1495 1496 Add_Matching_Formals (Formals, Actuals); 1497 1498 Call := 1499 Make_Procedure_Call_Statement (Loc, 1500 Name => Call_Nam, 1501 Parameter_Associations => Actuals); 1502 1503 -- Add renaming declarations for the discriminants of the enclosing type 1504 -- as the various contract items may reference them. 1505 1506 Add_Discriminant_Renamings (Obj_Id, Decls); 1507 1508 Wrapper_Id := 1509 Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E')); 1510 Set_Contract_Wrapper (E, Wrapper_Id); 1511 Set_Is_Entry_Wrapper (Wrapper_Id); 1512 1513 -- The wrapper body is analyzed when the enclosing type is frozen 1514 1515 Append_Freeze_Action (Defining_Entity (Decl), 1516 Make_Subprogram_Body (Loc, 1517 Specification => 1518 Make_Procedure_Specification (Loc, 1519 Defining_Unit_Name => Wrapper_Id, 1520 Parameter_Specifications => Formals), 1521 Declarations => Decls, 1522 Handled_Statement_Sequence => 1523 Make_Handled_Sequence_Of_Statements (Loc, 1524 Statements => New_List (Call)))); 1525 end Build_Contract_Wrapper; 1526 1527 -------------------------------- 1528 -- Build_Corresponding_Record -- 1529 -------------------------------- 1530 1531 function Build_Corresponding_Record 1532 (N : Node_Id; 1533 Ctyp : Entity_Id; 1534 Loc : Source_Ptr) return Node_Id 1535 is 1536 Rec_Ent : constant Entity_Id := 1537 Make_Defining_Identifier 1538 (Loc, New_External_Name (Chars (Ctyp), 'V')); 1539 Disc : Entity_Id; 1540 Dlist : List_Id; 1541 New_Disc : Entity_Id; 1542 Cdecls : List_Id; 1543 1544 begin 1545 Set_Corresponding_Record_Type (Ctyp, Rec_Ent); 1546 Set_Ekind (Rec_Ent, E_Record_Type); 1547 Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp)); 1548 Set_Is_Concurrent_Record_Type (Rec_Ent, True); 1549 Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp); 1550 Set_Stored_Constraint (Rec_Ent, No_Elist); 1551 Cdecls := New_List; 1552 1553 -- Use discriminals to create list of discriminants for record, and 1554 -- create new discriminals for use in default expressions, etc. It is 1555 -- worth noting that a task discriminant gives rise to 5 entities; 1556 1557 -- a) The original discriminant. 1558 -- b) The discriminal for use in the task. 1559 -- c) The discriminant of the corresponding record. 1560 -- d) The discriminal for the init proc of the corresponding record. 1561 -- e) The local variable that renames the discriminant in the procedure 1562 -- for the task body. 1563 1564 -- In fact the discriminals b) are used in the renaming declarations 1565 -- for e). See details in einfo (Handling of Discriminants). 1566 1567 if Present (Discriminant_Specifications (N)) then 1568 Dlist := New_List; 1569 Disc := First_Discriminant (Ctyp); 1570 1571 while Present (Disc) loop 1572 New_Disc := CR_Discriminant (Disc); 1573 1574 Append_To (Dlist, 1575 Make_Discriminant_Specification (Loc, 1576 Defining_Identifier => New_Disc, 1577 Discriminant_Type => 1578 New_Occurrence_Of (Etype (Disc), Loc), 1579 Expression => 1580 New_Copy (Discriminant_Default_Value (Disc)))); 1581 1582 Next_Discriminant (Disc); 1583 end loop; 1584 1585 else 1586 Dlist := No_List; 1587 end if; 1588 1589 -- Now we can construct the record type declaration. Note that this 1590 -- record is "limited tagged". It is "limited" to reflect the underlying 1591 -- limitedness of the task or protected object that it represents, and 1592 -- ensuring for example that it is properly passed by reference. It is 1593 -- "tagged" to give support to dispatching calls through interfaces. We 1594 -- propagate here the list of interfaces covered by the concurrent type 1595 -- (Ada 2005: AI-345). 1596 1597 return 1598 Make_Full_Type_Declaration (Loc, 1599 Defining_Identifier => Rec_Ent, 1600 Discriminant_Specifications => Dlist, 1601 Type_Definition => 1602 Make_Record_Definition (Loc, 1603 Component_List => 1604 Make_Component_List (Loc, Component_Items => Cdecls), 1605 Tagged_Present => 1606 Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp), 1607 Interface_List => Interface_List (N), 1608 Limited_Present => True)); 1609 end Build_Corresponding_Record; 1610 1611 --------------------------------- 1612 -- Build_Dispatching_Tag_Check -- 1613 --------------------------------- 1614 1615 function Build_Dispatching_Tag_Check 1616 (K : Entity_Id; 1617 N : Node_Id) return Node_Id 1618 is 1619 Loc : constant Source_Ptr := Sloc (N); 1620 1621 begin 1622 return 1623 Make_Op_Or (Loc, 1624 Make_Op_Eq (Loc, 1625 Left_Opnd => 1626 New_Occurrence_Of (K, Loc), 1627 Right_Opnd => 1628 New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc)), 1629 1630 Make_Op_Eq (Loc, 1631 Left_Opnd => 1632 New_Occurrence_Of (K, Loc), 1633 Right_Opnd => 1634 New_Occurrence_Of (RTE (RE_TK_Tagged), Loc))); 1635 end Build_Dispatching_Tag_Check; 1636 1637 ---------------------------------- 1638 -- Build_Entry_Count_Expression -- 1639 ---------------------------------- 1640 1641 function Build_Entry_Count_Expression 1642 (Concurrent_Type : Node_Id; 1643 Component_List : List_Id; 1644 Loc : Source_Ptr) return Node_Id 1645 is 1646 Eindx : Nat; 1647 Ent : Entity_Id; 1648 Ecount : Node_Id; 1649 Comp : Node_Id; 1650 Lo : Node_Id; 1651 Hi : Node_Id; 1652 Typ : Entity_Id; 1653 Large : Boolean; 1654 1655 begin 1656 -- Count number of non-family entries 1657 1658 Eindx := 0; 1659 Ent := First_Entity (Concurrent_Type); 1660 while Present (Ent) loop 1661 if Ekind (Ent) = E_Entry then 1662 Eindx := Eindx + 1; 1663 end if; 1664 1665 Next_Entity (Ent); 1666 end loop; 1667 1668 Ecount := Make_Integer_Literal (Loc, Eindx); 1669 1670 -- Loop through entry families building the addition nodes 1671 1672 Ent := First_Entity (Concurrent_Type); 1673 Comp := First (Component_List); 1674 while Present (Ent) loop 1675 if Ekind (Ent) = E_Entry_Family then 1676 while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop 1677 Next (Comp); 1678 end loop; 1679 1680 Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); 1681 Hi := Type_High_Bound (Typ); 1682 Lo := Type_Low_Bound (Typ); 1683 Large := Is_Potentially_Large_Family 1684 (Base_Type (Typ), Concurrent_Type, Lo, Hi); 1685 Ecount := 1686 Make_Op_Add (Loc, 1687 Left_Opnd => Ecount, 1688 Right_Opnd => 1689 Family_Size (Loc, Hi, Lo, Concurrent_Type, Large)); 1690 end if; 1691 1692 Next_Entity (Ent); 1693 end loop; 1694 1695 return Ecount; 1696 end Build_Entry_Count_Expression; 1697 1698 --------------------------- 1699 -- Build_Parameter_Block -- 1700 --------------------------- 1701 1702 function Build_Parameter_Block 1703 (Loc : Source_Ptr; 1704 Actuals : List_Id; 1705 Formals : List_Id; 1706 Decls : List_Id) return Entity_Id 1707 is 1708 Actual : Entity_Id; 1709 Comp_Nam : Node_Id; 1710 Comps : List_Id; 1711 Formal : Entity_Id; 1712 Has_Comp : Boolean := False; 1713 Rec_Nam : Node_Id; 1714 1715 begin 1716 Actual := First (Actuals); 1717 Comps := New_List; 1718 Formal := Defining_Identifier (First (Formals)); 1719 1720 while Present (Actual) loop 1721 if not Is_Controlling_Actual (Actual) then 1722 1723 -- Generate: 1724 -- type Ann is access all <actual-type> 1725 1726 Comp_Nam := Make_Temporary (Loc, 'A'); 1727 Set_Is_Param_Block_Component_Type (Comp_Nam); 1728 1729 Append_To (Decls, 1730 Make_Full_Type_Declaration (Loc, 1731 Defining_Identifier => Comp_Nam, 1732 Type_Definition => 1733 Make_Access_To_Object_Definition (Loc, 1734 All_Present => True, 1735 Constant_Present => Ekind (Formal) = E_In_Parameter, 1736 Subtype_Indication => 1737 New_Occurrence_Of (Etype (Actual), Loc)))); 1738 1739 -- Generate: 1740 -- Param : Ann; 1741 1742 Append_To (Comps, 1743 Make_Component_Declaration (Loc, 1744 Defining_Identifier => 1745 Make_Defining_Identifier (Loc, Chars (Formal)), 1746 Component_Definition => 1747 Make_Component_Definition (Loc, 1748 Aliased_Present => 1749 False, 1750 Subtype_Indication => 1751 New_Occurrence_Of (Comp_Nam, Loc)))); 1752 1753 Has_Comp := True; 1754 end if; 1755 1756 Next_Actual (Actual); 1757 Next_Formal_With_Extras (Formal); 1758 end loop; 1759 1760 Rec_Nam := Make_Temporary (Loc, 'P'); 1761 1762 if Has_Comp then 1763 1764 -- Generate: 1765 -- type Pnn is record 1766 -- Param1 : Ann1; 1767 -- ... 1768 -- ParamN : AnnN; 1769 1770 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are 1771 -- the original parameter names and Ann1 .. AnnN are the access to 1772 -- actual types. 1773 1774 Append_To (Decls, 1775 Make_Full_Type_Declaration (Loc, 1776 Defining_Identifier => 1777 Rec_Nam, 1778 Type_Definition => 1779 Make_Record_Definition (Loc, 1780 Component_List => 1781 Make_Component_List (Loc, Comps)))); 1782 else 1783 -- Generate: 1784 -- type Pnn is null record; 1785 1786 Append_To (Decls, 1787 Make_Full_Type_Declaration (Loc, 1788 Defining_Identifier => 1789 Rec_Nam, 1790 Type_Definition => 1791 Make_Record_Definition (Loc, 1792 Null_Present => True, 1793 Component_List => Empty))); 1794 end if; 1795 1796 return Rec_Nam; 1797 end Build_Parameter_Block; 1798 1799 -------------------------------------- 1800 -- Build_Renamed_Formal_Declaration -- 1801 -------------------------------------- 1802 1803 function Build_Renamed_Formal_Declaration 1804 (New_F : Entity_Id; 1805 Formal : Entity_Id; 1806 Comp : Entity_Id; 1807 Renamed_Formal : Node_Id) return Node_Id 1808 is 1809 Loc : constant Source_Ptr := Sloc (New_F); 1810 Decl : Node_Id; 1811 1812 begin 1813 -- If the formal is a tagged incomplete type, it is already passed 1814 -- by reference, so it is sufficient to rename the pointer component 1815 -- that corresponds to the actual. Otherwise we need to dereference 1816 -- the pointer component to obtain the actual. 1817 1818 if Is_Incomplete_Type (Etype (Formal)) 1819 and then Is_Tagged_Type (Etype (Formal)) 1820 then 1821 Decl := 1822 Make_Object_Renaming_Declaration (Loc, 1823 Defining_Identifier => New_F, 1824 Subtype_Mark => New_Occurrence_Of (Etype (Comp), Loc), 1825 Name => Renamed_Formal); 1826 1827 else 1828 Decl := 1829 Make_Object_Renaming_Declaration (Loc, 1830 Defining_Identifier => New_F, 1831 Subtype_Mark => New_Occurrence_Of (Etype (Formal), Loc), 1832 Name => 1833 Make_Explicit_Dereference (Loc, Renamed_Formal)); 1834 end if; 1835 1836 return Decl; 1837 end Build_Renamed_Formal_Declaration; 1838 1839 -------------------------- 1840 -- Build_Wrapper_Bodies -- 1841 -------------------------- 1842 1843 procedure Build_Wrapper_Bodies 1844 (Loc : Source_Ptr; 1845 Typ : Entity_Id; 1846 N : Node_Id) 1847 is 1848 Rec_Typ : Entity_Id; 1849 1850 function Build_Wrapper_Body 1851 (Loc : Source_Ptr; 1852 Subp_Id : Entity_Id; 1853 Obj_Typ : Entity_Id; 1854 Formals : List_Id) return Node_Id; 1855 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation 1856 -- associated with a protected or task type. Subp_Id is the subprogram 1857 -- name which will be wrapped. Obj_Typ is the type of the new formal 1858 -- parameter which handles dispatching and object notation. Formals are 1859 -- the original formals of Subp_Id which will be explicitly replicated. 1860 1861 ------------------------ 1862 -- Build_Wrapper_Body -- 1863 ------------------------ 1864 1865 function Build_Wrapper_Body 1866 (Loc : Source_Ptr; 1867 Subp_Id : Entity_Id; 1868 Obj_Typ : Entity_Id; 1869 Formals : List_Id) return Node_Id 1870 is 1871 Body_Spec : Node_Id; 1872 1873 begin 1874 Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals); 1875 1876 -- The subprogram is not overriding or is not a primitive declared 1877 -- between two views. 1878 1879 if No (Body_Spec) then 1880 return Empty; 1881 end if; 1882 1883 declare 1884 Actuals : List_Id := No_List; 1885 Conv_Id : Node_Id; 1886 First_Form : Node_Id; 1887 Formal : Node_Id; 1888 Nam : Node_Id; 1889 1890 begin 1891 -- Map formals to actuals. Use the list built for the wrapper 1892 -- spec, skipping the object notation parameter. 1893 1894 First_Form := First (Parameter_Specifications (Body_Spec)); 1895 1896 Formal := First_Form; 1897 Next (Formal); 1898 1899 if Present (Formal) then 1900 Actuals := New_List; 1901 while Present (Formal) loop 1902 Append_To (Actuals, 1903 Make_Identifier (Loc, 1904 Chars => Chars (Defining_Identifier (Formal)))); 1905 Next (Formal); 1906 end loop; 1907 end if; 1908 1909 -- Special processing for primitives declared between a private 1910 -- type and its completion: the wrapper needs a properly typed 1911 -- parameter if the wrapped operation has a controlling first 1912 -- parameter. Note that this might not be the case for a function 1913 -- with a controlling result. 1914 1915 if Is_Private_Primitive_Subprogram (Subp_Id) then 1916 if No (Actuals) then 1917 Actuals := New_List; 1918 end if; 1919 1920 if Is_Controlling_Formal (First_Formal (Subp_Id)) then 1921 Prepend_To (Actuals, 1922 Unchecked_Convert_To 1923 (Corresponding_Concurrent_Type (Obj_Typ), 1924 Make_Identifier (Loc, Name_uO))); 1925 1926 else 1927 Prepend_To (Actuals, 1928 Make_Identifier (Loc, 1929 Chars => Chars (Defining_Identifier (First_Form)))); 1930 end if; 1931 1932 Nam := New_Occurrence_Of (Subp_Id, Loc); 1933 else 1934 -- An access-to-variable object parameter requires an explicit 1935 -- dereference in the unchecked conversion. This case occurs 1936 -- when a protected entry wrapper must override an interface 1937 -- level procedure with interface access as first parameter. 1938 1939 -- O.all.Subp_Id (Formal_1, ..., Formal_N) 1940 1941 if Nkind (Parameter_Type (First_Form)) = 1942 N_Access_Definition 1943 then 1944 Conv_Id := 1945 Make_Explicit_Dereference (Loc, 1946 Prefix => Make_Identifier (Loc, Name_uO)); 1947 else 1948 Conv_Id := Make_Identifier (Loc, Name_uO); 1949 end if; 1950 1951 Nam := 1952 Make_Selected_Component (Loc, 1953 Prefix => 1954 Unchecked_Convert_To 1955 (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id), 1956 Selector_Name => New_Occurrence_Of (Subp_Id, Loc)); 1957 end if; 1958 1959 -- Create the subprogram body. For a function, the call to the 1960 -- actual subprogram has to be converted to the corresponding 1961 -- record if it is a controlling result. 1962 1963 if Ekind (Subp_Id) = E_Function then 1964 declare 1965 Res : Node_Id; 1966 1967 begin 1968 Res := 1969 Make_Function_Call (Loc, 1970 Name => Nam, 1971 Parameter_Associations => Actuals); 1972 1973 if Has_Controlling_Result (Subp_Id) then 1974 Res := 1975 Unchecked_Convert_To 1976 (Corresponding_Record_Type (Etype (Subp_Id)), Res); 1977 end if; 1978 1979 return 1980 Make_Subprogram_Body (Loc, 1981 Specification => Body_Spec, 1982 Declarations => Empty_List, 1983 Handled_Statement_Sequence => 1984 Make_Handled_Sequence_Of_Statements (Loc, 1985 Statements => New_List ( 1986 Make_Simple_Return_Statement (Loc, Res)))); 1987 end; 1988 1989 else 1990 return 1991 Make_Subprogram_Body (Loc, 1992 Specification => Body_Spec, 1993 Declarations => Empty_List, 1994 Handled_Statement_Sequence => 1995 Make_Handled_Sequence_Of_Statements (Loc, 1996 Statements => New_List ( 1997 Make_Procedure_Call_Statement (Loc, 1998 Name => Nam, 1999 Parameter_Associations => Actuals)))); 2000 end if; 2001 end; 2002 end Build_Wrapper_Body; 2003 2004 -- Start of processing for Build_Wrapper_Bodies 2005 2006 begin 2007 if Is_Concurrent_Type (Typ) then 2008 Rec_Typ := Corresponding_Record_Type (Typ); 2009 else 2010 Rec_Typ := Typ; 2011 end if; 2012 2013 -- Generate wrapper bodies for a concurrent type which implements an 2014 -- interface. 2015 2016 if Present (Interfaces (Rec_Typ)) then 2017 declare 2018 Insert_Nod : Node_Id; 2019 Prim : Entity_Id; 2020 Prim_Elmt : Elmt_Id; 2021 Prim_Decl : Node_Id; 2022 Subp : Entity_Id; 2023 Wrap_Body : Node_Id; 2024 Wrap_Id : Entity_Id; 2025 2026 begin 2027 Insert_Nod := N; 2028 2029 -- Examine all primitive operations of the corresponding record 2030 -- type, looking for wrapper specs. Generate bodies in order to 2031 -- complete them. 2032 2033 Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ)); 2034 while Present (Prim_Elmt) loop 2035 Prim := Node (Prim_Elmt); 2036 2037 if (Ekind (Prim) = E_Function 2038 or else Ekind (Prim) = E_Procedure) 2039 and then Is_Primitive_Wrapper (Prim) 2040 then 2041 Subp := Wrapped_Entity (Prim); 2042 Prim_Decl := Parent (Parent (Prim)); 2043 2044 Wrap_Body := 2045 Build_Wrapper_Body (Loc, 2046 Subp_Id => Subp, 2047 Obj_Typ => Rec_Typ, 2048 Formals => Parameter_Specifications (Parent (Subp))); 2049 Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body)); 2050 2051 Set_Corresponding_Spec (Wrap_Body, Prim); 2052 Set_Corresponding_Body (Prim_Decl, Wrap_Id); 2053 2054 Insert_After (Insert_Nod, Wrap_Body); 2055 Insert_Nod := Wrap_Body; 2056 2057 Analyze (Wrap_Body); 2058 end if; 2059 2060 Next_Elmt (Prim_Elmt); 2061 end loop; 2062 end; 2063 end if; 2064 end Build_Wrapper_Bodies; 2065 2066 ------------------------ 2067 -- Build_Wrapper_Spec -- 2068 ------------------------ 2069 2070 function Build_Wrapper_Spec 2071 (Subp_Id : Entity_Id; 2072 Obj_Typ : Entity_Id; 2073 Formals : List_Id) return Node_Id 2074 is 2075 function Overriding_Possible 2076 (Iface_Op : Entity_Id; 2077 Wrapper : Entity_Id) return Boolean; 2078 -- Determine whether a primitive operation can be overridden by Wrapper. 2079 -- Iface_Op is the candidate primitive operation of an interface type, 2080 -- Wrapper is the generated entry wrapper. 2081 2082 function Replicate_Formals 2083 (Loc : Source_Ptr; 2084 Formals : List_Id) return List_Id; 2085 -- An explicit parameter replication is required due to the Is_Entry_ 2086 -- Formal flag being set for all the formals of an entry. The explicit 2087 -- replication removes the flag that would otherwise cause a different 2088 -- path of analysis. 2089 2090 ------------------------- 2091 -- Overriding_Possible -- 2092 ------------------------- 2093 2094 function Overriding_Possible 2095 (Iface_Op : Entity_Id; 2096 Wrapper : Entity_Id) return Boolean 2097 is 2098 Iface_Op_Spec : constant Node_Id := Parent (Iface_Op); 2099 Wrapper_Spec : constant Node_Id := Parent (Wrapper); 2100 2101 function Type_Conformant_Parameters 2102 (Iface_Op_Params : List_Id; 2103 Wrapper_Params : List_Id) return Boolean; 2104 -- Determine whether the parameters of the generated entry wrapper 2105 -- and those of a primitive operation are type conformant. During 2106 -- this check, the first parameter of the primitive operation is 2107 -- skipped if it is a controlling argument: protected functions 2108 -- may have a controlling result. 2109 2110 -------------------------------- 2111 -- Type_Conformant_Parameters -- 2112 -------------------------------- 2113 2114 function Type_Conformant_Parameters 2115 (Iface_Op_Params : List_Id; 2116 Wrapper_Params : List_Id) return Boolean 2117 is 2118 Iface_Op_Param : Node_Id; 2119 Iface_Op_Typ : Entity_Id; 2120 Wrapper_Param : Node_Id; 2121 Wrapper_Typ : Entity_Id; 2122 2123 begin 2124 -- Skip the first (controlling) parameter of primitive operation 2125 2126 Iface_Op_Param := First (Iface_Op_Params); 2127 2128 if Present (First_Formal (Iface_Op)) 2129 and then Is_Controlling_Formal (First_Formal (Iface_Op)) 2130 then 2131 Iface_Op_Param := Next (Iface_Op_Param); 2132 end if; 2133 2134 Wrapper_Param := First (Wrapper_Params); 2135 while Present (Iface_Op_Param) 2136 and then Present (Wrapper_Param) 2137 loop 2138 Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param); 2139 Wrapper_Typ := Find_Parameter_Type (Wrapper_Param); 2140 2141 -- The two parameters must be mode conformant 2142 2143 if not Conforming_Types 2144 (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant) 2145 then 2146 return False; 2147 end if; 2148 2149 Next (Iface_Op_Param); 2150 Next (Wrapper_Param); 2151 end loop; 2152 2153 -- One of the lists is longer than the other 2154 2155 if Present (Iface_Op_Param) or else Present (Wrapper_Param) then 2156 return False; 2157 end if; 2158 2159 return True; 2160 end Type_Conformant_Parameters; 2161 2162 -- Start of processing for Overriding_Possible 2163 2164 begin 2165 if Chars (Iface_Op) /= Chars (Wrapper) then 2166 return False; 2167 end if; 2168 2169 -- If an inherited subprogram is implemented by a protected procedure 2170 -- or an entry, then the first parameter of the inherited subprogram 2171 -- must be of mode OUT or IN OUT, or access-to-variable parameter. 2172 2173 if Ekind (Iface_Op) = E_Procedure 2174 and then Present (Parameter_Specifications (Iface_Op_Spec)) 2175 then 2176 declare 2177 Obj_Param : constant Node_Id := 2178 First (Parameter_Specifications (Iface_Op_Spec)); 2179 begin 2180 if not Out_Present (Obj_Param) 2181 and then Nkind (Parameter_Type (Obj_Param)) /= 2182 N_Access_Definition 2183 then 2184 return False; 2185 end if; 2186 end; 2187 end if; 2188 2189 return 2190 Type_Conformant_Parameters 2191 (Parameter_Specifications (Iface_Op_Spec), 2192 Parameter_Specifications (Wrapper_Spec)); 2193 end Overriding_Possible; 2194 2195 ----------------------- 2196 -- Replicate_Formals -- 2197 ----------------------- 2198 2199 function Replicate_Formals 2200 (Loc : Source_Ptr; 2201 Formals : List_Id) return List_Id 2202 is 2203 New_Formals : constant List_Id := New_List; 2204 Formal : Node_Id; 2205 Param_Type : Node_Id; 2206 2207 begin 2208 Formal := First (Formals); 2209 2210 -- Skip the object parameter when dealing with primitives declared 2211 -- between two views. 2212 2213 if Is_Private_Primitive_Subprogram (Subp_Id) 2214 and then not Has_Controlling_Result (Subp_Id) 2215 then 2216 Formal := Next (Formal); 2217 end if; 2218 2219 while Present (Formal) loop 2220 2221 -- Create an explicit copy of the entry parameter 2222 2223 -- When creating the wrapper subprogram for a primitive operation 2224 -- of a protected interface we must construct an equivalent 2225 -- signature to that of the overriding operation. For regular 2226 -- parameters we can just use the type of the formal, but for 2227 -- access to subprogram parameters we need to reanalyze the 2228 -- parameter type to create local entities for the signature of 2229 -- the subprogram type. Using the entities of the overriding 2230 -- subprogram will result in out-of-scope errors in the back-end. 2231 2232 if Nkind (Parameter_Type (Formal)) = N_Access_Definition then 2233 Param_Type := Copy_Separate_Tree (Parameter_Type (Formal)); 2234 else 2235 Param_Type := 2236 New_Occurrence_Of (Etype (Parameter_Type (Formal)), Loc); 2237 end if; 2238 2239 Append_To (New_Formals, 2240 Make_Parameter_Specification (Loc, 2241 Defining_Identifier => 2242 Make_Defining_Identifier (Loc, 2243 Chars => Chars (Defining_Identifier (Formal))), 2244 In_Present => In_Present (Formal), 2245 Out_Present => Out_Present (Formal), 2246 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 2247 Parameter_Type => Param_Type)); 2248 2249 Next (Formal); 2250 end loop; 2251 2252 return New_Formals; 2253 end Replicate_Formals; 2254 2255 -- Local variables 2256 2257 Loc : constant Source_Ptr := Sloc (Subp_Id); 2258 First_Param : Node_Id := Empty; 2259 Iface : Entity_Id; 2260 Iface_Elmt : Elmt_Id; 2261 Iface_Op : Entity_Id; 2262 Iface_Op_Elmt : Elmt_Id; 2263 Overridden_Subp : Entity_Id; 2264 2265 -- Start of processing for Build_Wrapper_Spec 2266 2267 begin 2268 -- No point in building wrappers for untagged concurrent types 2269 2270 pragma Assert (Is_Tagged_Type (Obj_Typ)); 2271 2272 -- Check if this subprogram has a profile that matches some interface 2273 -- primitive. 2274 2275 Check_Synchronized_Overriding (Subp_Id, Overridden_Subp); 2276 2277 if Present (Overridden_Subp) then 2278 First_Param := 2279 First (Parameter_Specifications (Parent (Overridden_Subp))); 2280 2281 -- An entry or a protected procedure can override a routine where the 2282 -- controlling formal is either IN OUT, OUT or is of access-to-variable 2283 -- type. Since the wrapper must have the exact same signature as that of 2284 -- the overridden subprogram, we try to find the overriding candidate 2285 -- and use its controlling formal. 2286 2287 -- Check every implemented interface 2288 2289 elsif Present (Interfaces (Obj_Typ)) then 2290 Iface_Elmt := First_Elmt (Interfaces (Obj_Typ)); 2291 Search : while Present (Iface_Elmt) loop 2292 Iface := Node (Iface_Elmt); 2293 2294 -- Check every interface primitive 2295 2296 if Present (Primitive_Operations (Iface)) then 2297 Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); 2298 while Present (Iface_Op_Elmt) loop 2299 Iface_Op := Node (Iface_Op_Elmt); 2300 2301 -- Ignore predefined primitives 2302 2303 if not Is_Predefined_Dispatching_Operation (Iface_Op) then 2304 Iface_Op := Ultimate_Alias (Iface_Op); 2305 2306 -- The current primitive operation can be overridden by 2307 -- the generated entry wrapper. 2308 2309 if Overriding_Possible (Iface_Op, Subp_Id) then 2310 First_Param := 2311 First (Parameter_Specifications (Parent (Iface_Op))); 2312 2313 exit Search; 2314 end if; 2315 end if; 2316 2317 Next_Elmt (Iface_Op_Elmt); 2318 end loop; 2319 end if; 2320 2321 Next_Elmt (Iface_Elmt); 2322 end loop Search; 2323 end if; 2324 2325 -- Do not generate the wrapper if no interface primitive is covered by 2326 -- the subprogram and it is not a primitive declared between two views 2327 -- (see Process_Full_View). 2328 2329 if No (First_Param) 2330 and then not Is_Private_Primitive_Subprogram (Subp_Id) 2331 then 2332 return Empty; 2333 end if; 2334 2335 declare 2336 Wrapper_Id : constant Entity_Id := 2337 Make_Defining_Identifier (Loc, Chars (Subp_Id)); 2338 New_Formals : List_Id; 2339 Obj_Param : Node_Id; 2340 Obj_Param_Typ : Entity_Id; 2341 2342 begin 2343 -- Minimum decoration is needed to catch the entity in 2344 -- Sem_Ch6.Override_Dispatching_Operation. 2345 2346 if Ekind (Subp_Id) = E_Function then 2347 Set_Ekind (Wrapper_Id, E_Function); 2348 else 2349 Set_Ekind (Wrapper_Id, E_Procedure); 2350 end if; 2351 2352 Set_Is_Primitive_Wrapper (Wrapper_Id); 2353 Set_Wrapped_Entity (Wrapper_Id, Subp_Id); 2354 Set_Is_Private_Primitive (Wrapper_Id, 2355 Is_Private_Primitive_Subprogram (Subp_Id)); 2356 2357 -- Process the formals 2358 2359 New_Formals := Replicate_Formals (Loc, Formals); 2360 2361 -- A function with a controlling result and no first controlling 2362 -- formal needs no additional parameter. 2363 2364 if Has_Controlling_Result (Subp_Id) 2365 and then 2366 (No (First_Formal (Subp_Id)) 2367 or else not Is_Controlling_Formal (First_Formal (Subp_Id))) 2368 then 2369 null; 2370 2371 -- Routine Subp_Id has been found to override an interface primitive. 2372 -- If the interface operation has an access parameter, create a copy 2373 -- of it, with the same null exclusion indicator if present. 2374 2375 elsif Present (First_Param) then 2376 if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then 2377 Obj_Param_Typ := 2378 Make_Access_Definition (Loc, 2379 Subtype_Mark => 2380 New_Occurrence_Of (Obj_Typ, Loc), 2381 Null_Exclusion_Present => 2382 Null_Exclusion_Present (Parameter_Type (First_Param)), 2383 Constant_Present => 2384 Constant_Present (Parameter_Type (First_Param))); 2385 else 2386 Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc); 2387 end if; 2388 2389 Obj_Param := 2390 Make_Parameter_Specification (Loc, 2391 Defining_Identifier => 2392 Make_Defining_Identifier (Loc, 2393 Chars => Name_uO), 2394 In_Present => In_Present (First_Param), 2395 Out_Present => Out_Present (First_Param), 2396 Parameter_Type => Obj_Param_Typ); 2397 2398 Prepend_To (New_Formals, Obj_Param); 2399 2400 -- If we are dealing with a primitive declared between two views, 2401 -- implemented by a synchronized operation, we need to create 2402 -- a default parameter. The mode of the parameter must match that 2403 -- of the primitive operation. 2404 2405 else 2406 pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id)); 2407 2408 Obj_Param := 2409 Make_Parameter_Specification (Loc, 2410 Defining_Identifier => 2411 Make_Defining_Identifier (Loc, Name_uO), 2412 In_Present => 2413 In_Present (Parent (First_Entity (Subp_Id))), 2414 Out_Present => Ekind (Subp_Id) /= E_Function, 2415 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); 2416 2417 Prepend_To (New_Formals, Obj_Param); 2418 end if; 2419 2420 -- Build the final spec. If it is a function with a controlling 2421 -- result, it is a primitive operation of the corresponding 2422 -- record type, so mark the spec accordingly. 2423 2424 if Ekind (Subp_Id) = E_Function then 2425 declare 2426 Res_Def : Node_Id; 2427 2428 begin 2429 if Has_Controlling_Result (Subp_Id) then 2430 Res_Def := 2431 New_Occurrence_Of 2432 (Corresponding_Record_Type (Etype (Subp_Id)), Loc); 2433 else 2434 Res_Def := New_Copy (Result_Definition (Parent (Subp_Id))); 2435 end if; 2436 2437 return 2438 Make_Function_Specification (Loc, 2439 Defining_Unit_Name => Wrapper_Id, 2440 Parameter_Specifications => New_Formals, 2441 Result_Definition => Res_Def); 2442 end; 2443 else 2444 return 2445 Make_Procedure_Specification (Loc, 2446 Defining_Unit_Name => Wrapper_Id, 2447 Parameter_Specifications => New_Formals); 2448 end if; 2449 end; 2450 end Build_Wrapper_Spec; 2451 2452 ------------------------- 2453 -- Build_Wrapper_Specs -- 2454 ------------------------- 2455 2456 procedure Build_Wrapper_Specs 2457 (Loc : Source_Ptr; 2458 Typ : Entity_Id; 2459 N : in out Node_Id) 2460 is 2461 Def : Node_Id; 2462 Rec_Typ : Entity_Id; 2463 procedure Scan_Declarations (L : List_Id); 2464 -- Common processing for visible and private declarations 2465 -- of a protected type. 2466 2467 procedure Scan_Declarations (L : List_Id) is 2468 Decl : Node_Id; 2469 Wrap_Decl : Node_Id; 2470 Wrap_Spec : Node_Id; 2471 2472 begin 2473 if No (L) then 2474 return; 2475 end if; 2476 2477 Decl := First (L); 2478 while Present (Decl) loop 2479 Wrap_Spec := Empty; 2480 2481 if Nkind (Decl) = N_Entry_Declaration 2482 and then Ekind (Defining_Identifier (Decl)) = E_Entry 2483 then 2484 Wrap_Spec := 2485 Build_Wrapper_Spec 2486 (Subp_Id => Defining_Identifier (Decl), 2487 Obj_Typ => Rec_Typ, 2488 Formals => Parameter_Specifications (Decl)); 2489 2490 elsif Nkind (Decl) = N_Subprogram_Declaration then 2491 Wrap_Spec := 2492 Build_Wrapper_Spec 2493 (Subp_Id => Defining_Unit_Name (Specification (Decl)), 2494 Obj_Typ => Rec_Typ, 2495 Formals => 2496 Parameter_Specifications (Specification (Decl))); 2497 end if; 2498 2499 if Present (Wrap_Spec) then 2500 Wrap_Decl := 2501 Make_Subprogram_Declaration (Loc, 2502 Specification => Wrap_Spec); 2503 2504 Insert_After (N, Wrap_Decl); 2505 N := Wrap_Decl; 2506 2507 Analyze (Wrap_Decl); 2508 end if; 2509 2510 Next (Decl); 2511 end loop; 2512 end Scan_Declarations; 2513 2514 -- start of processing for Build_Wrapper_Specs 2515 2516 begin 2517 if Is_Protected_Type (Typ) then 2518 Def := Protected_Definition (Parent (Typ)); 2519 else pragma Assert (Is_Task_Type (Typ)); 2520 Def := Task_Definition (Parent (Typ)); 2521 end if; 2522 2523 Rec_Typ := Corresponding_Record_Type (Typ); 2524 2525 -- Generate wrapper specs for a concurrent type which implements an 2526 -- interface. Operations in both the visible and private parts may 2527 -- implement progenitor operations. 2528 2529 if Present (Interfaces (Rec_Typ)) and then Present (Def) then 2530 Scan_Declarations (Visible_Declarations (Def)); 2531 Scan_Declarations (Private_Declarations (Def)); 2532 end if; 2533 end Build_Wrapper_Specs; 2534 2535 --------------------------- 2536 -- Build_Find_Body_Index -- 2537 --------------------------- 2538 2539 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is 2540 Loc : constant Source_Ptr := Sloc (Typ); 2541 Ent : Entity_Id; 2542 E_Typ : Entity_Id; 2543 Has_F : Boolean := False; 2544 Index : Nat; 2545 If_St : Node_Id := Empty; 2546 Lo : Node_Id; 2547 Hi : Node_Id; 2548 Decls : List_Id := New_List; 2549 Ret : Node_Id; 2550 Spec : Node_Id; 2551 Siz : Node_Id := Empty; 2552 2553 procedure Add_If_Clause (Expr : Node_Id); 2554 -- Add test for range of current entry 2555 2556 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 2557 -- If a bound of an entry is given by a discriminant, retrieve the 2558 -- actual value of the discriminant from the enclosing object. 2559 2560 ------------------- 2561 -- Add_If_Clause -- 2562 ------------------- 2563 2564 procedure Add_If_Clause (Expr : Node_Id) is 2565 Cond : Node_Id; 2566 Stats : constant List_Id := 2567 New_List ( 2568 Make_Simple_Return_Statement (Loc, 2569 Expression => Make_Integer_Literal (Loc, Index + 1))); 2570 2571 begin 2572 -- Index for current entry body 2573 2574 Index := Index + 1; 2575 2576 -- Compute total length of entry queues so far 2577 2578 if No (Siz) then 2579 Siz := Expr; 2580 else 2581 Siz := 2582 Make_Op_Add (Loc, 2583 Left_Opnd => Siz, 2584 Right_Opnd => Expr); 2585 end if; 2586 2587 Cond := 2588 Make_Op_Le (Loc, 2589 Left_Opnd => Make_Identifier (Loc, Name_uE), 2590 Right_Opnd => Siz); 2591 2592 -- Map entry queue indexes in the range of the current family 2593 -- into the current index, that designates the entry body. 2594 2595 if No (If_St) then 2596 If_St := 2597 Make_Implicit_If_Statement (Typ, 2598 Condition => Cond, 2599 Then_Statements => Stats, 2600 Elsif_Parts => New_List); 2601 Ret := If_St; 2602 2603 else 2604 Append_To (Elsif_Parts (If_St), 2605 Make_Elsif_Part (Loc, 2606 Condition => Cond, 2607 Then_Statements => Stats)); 2608 end if; 2609 end Add_If_Clause; 2610 2611 ------------------------------ 2612 -- Convert_Discriminant_Ref -- 2613 ------------------------------ 2614 2615 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 2616 B : Node_Id; 2617 2618 begin 2619 if Is_Entity_Name (Bound) 2620 and then Ekind (Entity (Bound)) = E_Discriminant 2621 then 2622 B := 2623 Make_Selected_Component (Loc, 2624 Prefix => 2625 Unchecked_Convert_To (Corresponding_Record_Type (Typ), 2626 Make_Explicit_Dereference (Loc, 2627 Make_Identifier (Loc, Name_uObject))), 2628 Selector_Name => Make_Identifier (Loc, Chars (Bound))); 2629 Set_Etype (B, Etype (Entity (Bound))); 2630 else 2631 B := New_Copy_Tree (Bound); 2632 end if; 2633 2634 return B; 2635 end Convert_Discriminant_Ref; 2636 2637 -- Start of processing for Build_Find_Body_Index 2638 2639 begin 2640 Spec := Build_Find_Body_Index_Spec (Typ); 2641 2642 Ent := First_Entity (Typ); 2643 while Present (Ent) loop 2644 if Ekind (Ent) = E_Entry_Family then 2645 Has_F := True; 2646 exit; 2647 end if; 2648 2649 Next_Entity (Ent); 2650 end loop; 2651 2652 if not Has_F then 2653 2654 -- If the protected type has no entry families, there is a one-one 2655 -- correspondence between entry queue and entry body. 2656 2657 Ret := 2658 Make_Simple_Return_Statement (Loc, 2659 Expression => Make_Identifier (Loc, Name_uE)); 2660 2661 else 2662 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate 2663 -- the following: 2664 2665 -- if E <= l1 then return 1; 2666 -- elsif E <= l1 + l2 then return 2; 2667 -- ... 2668 2669 Index := 0; 2670 Siz := Empty; 2671 Ent := First_Entity (Typ); 2672 2673 Add_Object_Pointer (Loc, Typ, Decls); 2674 2675 while Present (Ent) loop 2676 if Ekind (Ent) = E_Entry then 2677 Add_If_Clause (Make_Integer_Literal (Loc, 1)); 2678 2679 elsif Ekind (Ent) = E_Entry_Family then 2680 E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); 2681 Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); 2682 Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); 2683 Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False)); 2684 end if; 2685 2686 Next_Entity (Ent); 2687 end loop; 2688 2689 if Index = 1 then 2690 Decls := New_List; 2691 Ret := 2692 Make_Simple_Return_Statement (Loc, 2693 Expression => Make_Integer_Literal (Loc, 1)); 2694 2695 elsif Nkind (Ret) = N_If_Statement then 2696 2697 -- Ranges are in increasing order, so last one doesn't need guard 2698 2699 declare 2700 Nod : constant Node_Id := Last (Elsif_Parts (Ret)); 2701 begin 2702 Remove (Nod); 2703 Set_Else_Statements (Ret, Then_Statements (Nod)); 2704 end; 2705 end if; 2706 end if; 2707 2708 return 2709 Make_Subprogram_Body (Loc, 2710 Specification => Spec, 2711 Declarations => Decls, 2712 Handled_Statement_Sequence => 2713 Make_Handled_Sequence_Of_Statements (Loc, 2714 Statements => New_List (Ret))); 2715 end Build_Find_Body_Index; 2716 2717 -------------------------------- 2718 -- Build_Find_Body_Index_Spec -- 2719 -------------------------------- 2720 2721 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is 2722 Loc : constant Source_Ptr := Sloc (Typ); 2723 Id : constant Entity_Id := 2724 Make_Defining_Identifier (Loc, 2725 Chars => New_External_Name (Chars (Typ), 'F')); 2726 Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO); 2727 Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE); 2728 2729 begin 2730 return 2731 Make_Function_Specification (Loc, 2732 Defining_Unit_Name => Id, 2733 Parameter_Specifications => New_List ( 2734 Make_Parameter_Specification (Loc, 2735 Defining_Identifier => Parm1, 2736 Parameter_Type => 2737 New_Occurrence_Of (RTE (RE_Address), Loc)), 2738 2739 Make_Parameter_Specification (Loc, 2740 Defining_Identifier => Parm2, 2741 Parameter_Type => 2742 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), 2743 2744 Result_Definition => New_Occurrence_Of ( 2745 RTE (RE_Protected_Entry_Index), Loc)); 2746 end Build_Find_Body_Index_Spec; 2747 2748 ----------------------------------------------- 2749 -- Build_Lock_Free_Protected_Subprogram_Body -- 2750 ----------------------------------------------- 2751 2752 function Build_Lock_Free_Protected_Subprogram_Body 2753 (N : Node_Id; 2754 Prot_Typ : Node_Id; 2755 Unprot_Spec : Node_Id) return Node_Id 2756 is 2757 Actuals : constant List_Id := New_List; 2758 Loc : constant Source_Ptr := Sloc (N); 2759 Spec : constant Node_Id := Specification (N); 2760 Unprot_Id : constant Entity_Id := Defining_Unit_Name (Unprot_Spec); 2761 Formal : Node_Id; 2762 Prot_Spec : Node_Id; 2763 Stmt : Node_Id; 2764 2765 begin 2766 -- Create the protected version of the body 2767 2768 Prot_Spec := 2769 Build_Protected_Sub_Specification (N, Prot_Typ, Protected_Mode); 2770 2771 -- Build the actual parameters which appear in the call to the 2772 -- unprotected version of the body. 2773 2774 Formal := First (Parameter_Specifications (Prot_Spec)); 2775 while Present (Formal) loop 2776 Append_To (Actuals, 2777 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 2778 2779 Next (Formal); 2780 end loop; 2781 2782 -- Function case, generate: 2783 -- return <Unprot_Func_Call>; 2784 2785 if Nkind (Spec) = N_Function_Specification then 2786 Stmt := 2787 Make_Simple_Return_Statement (Loc, 2788 Expression => 2789 Make_Function_Call (Loc, 2790 Name => 2791 Make_Identifier (Loc, Chars (Unprot_Id)), 2792 Parameter_Associations => Actuals)); 2793 2794 -- Procedure case, call the unprotected version 2795 2796 else 2797 Stmt := 2798 Make_Procedure_Call_Statement (Loc, 2799 Name => 2800 Make_Identifier (Loc, Chars (Unprot_Id)), 2801 Parameter_Associations => Actuals); 2802 end if; 2803 2804 return 2805 Make_Subprogram_Body (Loc, 2806 Declarations => Empty_List, 2807 Specification => Prot_Spec, 2808 Handled_Statement_Sequence => 2809 Make_Handled_Sequence_Of_Statements (Loc, 2810 Statements => New_List (Stmt))); 2811 end Build_Lock_Free_Protected_Subprogram_Body; 2812 2813 ------------------------------------------------- 2814 -- Build_Lock_Free_Unprotected_Subprogram_Body -- 2815 ------------------------------------------------- 2816 2817 -- Procedures which meet the lock-free implementation requirements and 2818 -- reference a unique scalar component Comp are expanded in the following 2819 -- manner: 2820 2821 -- procedure P (...) is 2822 -- Expected_Comp : constant Comp_Type := 2823 -- Comp_Type 2824 -- (System.Atomic_Primitives.Lock_Free_Read_N 2825 -- (_Object.Comp'Address)); 2826 -- begin 2827 -- loop 2828 -- declare 2829 -- <original declarations before the object renaming declaration 2830 -- of Comp> 2831 -- 2832 -- Desired_Comp : Comp_Type := Expected_Comp; 2833 -- Comp : Comp_Type renames Desired_Comp; 2834 -- 2835 -- <original delarations after the object renaming declaration 2836 -- of Comp> 2837 -- 2838 -- begin 2839 -- <original statements> 2840 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N 2841 -- (_Object.Comp'Address, 2842 -- Interfaces.Unsigned_N (Expected_Comp), 2843 -- Interfaces.Unsigned_N (Desired_Comp)); 2844 -- end; 2845 -- end loop; 2846 -- end P; 2847 2848 -- Each return and raise statement of P is transformed into an atomic 2849 -- status check: 2850 2851 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 2852 -- (_Object.Comp'Address, 2853 -- Interfaces.Unsigned_N (Expected_Comp), 2854 -- Interfaces.Unsigned_N (Desired_Comp)); 2855 -- then 2856 -- <original statement> 2857 -- else 2858 -- goto L0; 2859 -- end if; 2860 2861 -- Functions which meet the lock-free implementation requirements and 2862 -- reference a unique scalar component Comp are expanded in the following 2863 -- manner: 2864 2865 -- function F (...) return ... is 2866 -- <original declarations before the object renaming declaration 2867 -- of Comp> 2868 -- 2869 -- Expected_Comp : constant Comp_Type := 2870 -- Comp_Type 2871 -- (System.Atomic_Primitives.Lock_Free_Read_N 2872 -- (_Object.Comp'Address)); 2873 -- Comp : Comp_Type renames Expected_Comp; 2874 -- 2875 -- <original delarations after the object renaming declaration of 2876 -- Comp> 2877 -- 2878 -- begin 2879 -- <original statements> 2880 -- end F; 2881 2882 function Build_Lock_Free_Unprotected_Subprogram_Body 2883 (N : Node_Id; 2884 Prot_Typ : Node_Id) return Node_Id 2885 is 2886 function Referenced_Component (N : Node_Id) return Entity_Id; 2887 -- Subprograms which meet the lock-free implementation criteria are 2888 -- allowed to reference only one unique component. Return the prival 2889 -- of the said component. 2890 2891 -------------------------- 2892 -- Referenced_Component -- 2893 -------------------------- 2894 2895 function Referenced_Component (N : Node_Id) return Entity_Id is 2896 Comp : Entity_Id; 2897 Decl : Node_Id; 2898 Source_Comp : Entity_Id := Empty; 2899 2900 begin 2901 -- Find the unique source component which N references in its 2902 -- statements. 2903 2904 for Index in 1 .. Lock_Free_Subprogram_Table.Last loop 2905 declare 2906 Element : Lock_Free_Subprogram renames 2907 Lock_Free_Subprogram_Table.Table (Index); 2908 begin 2909 if Element.Sub_Body = N then 2910 Source_Comp := Element.Comp_Id; 2911 exit; 2912 end if; 2913 end; 2914 end loop; 2915 2916 if No (Source_Comp) then 2917 return Empty; 2918 end if; 2919 2920 -- Find the prival which corresponds to the source component within 2921 -- the declarations of N. 2922 2923 Decl := First (Declarations (N)); 2924 while Present (Decl) loop 2925 2926 -- Privals appear as object renamings 2927 2928 if Nkind (Decl) = N_Object_Renaming_Declaration then 2929 Comp := Defining_Identifier (Decl); 2930 2931 if Present (Prival_Link (Comp)) 2932 and then Prival_Link (Comp) = Source_Comp 2933 then 2934 return Comp; 2935 end if; 2936 end if; 2937 2938 Next (Decl); 2939 end loop; 2940 2941 return Empty; 2942 end Referenced_Component; 2943 2944 -- Local variables 2945 2946 Comp : constant Entity_Id := Referenced_Component (N); 2947 Loc : constant Source_Ptr := Sloc (N); 2948 Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N); 2949 Decls : List_Id := Declarations (N); 2950 2951 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body 2952 2953 begin 2954 -- Add renamings for the protection object, discriminals, privals, and 2955 -- the entry index constant for use by debugger. 2956 2957 Debug_Private_Data_Declarations (Decls); 2958 2959 -- Perform the lock-free expansion when the subprogram references a 2960 -- protected component. 2961 2962 if Present (Comp) then 2963 Protected_Component_Ref : declare 2964 Comp_Decl : constant Node_Id := Parent (Comp); 2965 Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl); 2966 Comp_Type : constant Entity_Id := Etype (Comp); 2967 2968 Is_Procedure : constant Boolean := 2969 Ekind (Corresponding_Spec (N)) = E_Procedure; 2970 -- Indicates if N is a protected procedure body 2971 2972 Block_Decls : List_Id := No_List; 2973 Try_Write : Entity_Id; 2974 Desired_Comp : Entity_Id; 2975 Decl : Node_Id; 2976 Label : Node_Id; 2977 Label_Id : Entity_Id := Empty; 2978 Read : Entity_Id; 2979 Expected_Comp : Entity_Id; 2980 Stmt : Node_Id; 2981 Stmts : List_Id := 2982 New_Copy_List (Statements (Hand_Stmt_Seq)); 2983 Typ_Size : Int; 2984 Unsigned : Entity_Id; 2985 2986 function Process_Node (N : Node_Id) return Traverse_Result; 2987 -- Transform a single node if it is a return statement, a raise 2988 -- statement or a reference to Comp. 2989 2990 procedure Process_Stmts (Stmts : List_Id); 2991 -- Given a statement sequence Stmts, wrap any return or raise 2992 -- statements in the following manner: 2993 -- 2994 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 2995 -- (_Object.Comp'Address, 2996 -- Interfaces.Unsigned_N (Expected_Comp), 2997 -- Interfaces.Unsigned_N (Desired_Comp)) 2998 -- then 2999 -- <Stmt>; 3000 -- else 3001 -- goto L0; 3002 -- end if; 3003 3004 ------------------ 3005 -- Process_Node -- 3006 ------------------ 3007 3008 function Process_Node (N : Node_Id) return Traverse_Result is 3009 3010 procedure Wrap_Statement (Stmt : Node_Id); 3011 -- Wrap an arbitrary statement inside an if statement where the 3012 -- condition does an atomic check on the state of the object. 3013 3014 -------------------- 3015 -- Wrap_Statement -- 3016 -------------------- 3017 3018 procedure Wrap_Statement (Stmt : Node_Id) is 3019 begin 3020 -- The first time through, create the declaration of a label 3021 -- which is used to skip the remainder of source statements 3022 -- if the state of the object has changed. 3023 3024 if No (Label_Id) then 3025 Label_Id := 3026 Make_Identifier (Loc, New_External_Name ('L', 0)); 3027 Set_Entity (Label_Id, 3028 Make_Defining_Identifier (Loc, Chars (Label_Id))); 3029 end if; 3030 3031 -- Generate: 3032 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3033 -- (_Object.Comp'Address, 3034 -- Interfaces.Unsigned_N (Expected_Comp), 3035 -- Interfaces.Unsigned_N (Desired_Comp)) 3036 -- then 3037 -- <Stmt>; 3038 -- else 3039 -- goto L0; 3040 -- end if; 3041 3042 Rewrite (Stmt, 3043 Make_Implicit_If_Statement (N, 3044 Condition => 3045 Make_Function_Call (Loc, 3046 Name => 3047 New_Occurrence_Of (Try_Write, Loc), 3048 Parameter_Associations => New_List ( 3049 Make_Attribute_Reference (Loc, 3050 Prefix => Relocate_Node (Comp_Sel_Nam), 3051 Attribute_Name => Name_Address), 3052 3053 Unchecked_Convert_To (Unsigned, 3054 New_Occurrence_Of (Expected_Comp, Loc)), 3055 3056 Unchecked_Convert_To (Unsigned, 3057 New_Occurrence_Of (Desired_Comp, Loc)))), 3058 3059 Then_Statements => New_List (Relocate_Node (Stmt)), 3060 3061 Else_Statements => New_List ( 3062 Make_Goto_Statement (Loc, 3063 Name => 3064 New_Occurrence_Of (Entity (Label_Id), Loc))))); 3065 end Wrap_Statement; 3066 3067 -- Start of processing for Process_Node 3068 3069 begin 3070 -- Wrap each return and raise statement that appear inside a 3071 -- procedure. Skip the last return statement which is added by 3072 -- default since it is transformed into an exit statement. 3073 3074 if Is_Procedure 3075 and then ((Nkind (N) = N_Simple_Return_Statement 3076 and then N /= Last (Stmts)) 3077 or else Nkind (N) = N_Extended_Return_Statement 3078 or else (Nkind_In (N, N_Raise_Constraint_Error, 3079 N_Raise_Program_Error, 3080 N_Raise_Statement, 3081 N_Raise_Storage_Error) 3082 and then Comes_From_Source (N))) 3083 then 3084 Wrap_Statement (N); 3085 return Skip; 3086 end if; 3087 3088 -- Force reanalysis 3089 3090 Set_Analyzed (N, False); 3091 3092 return OK; 3093 end Process_Node; 3094 3095 procedure Process_Nodes is new Traverse_Proc (Process_Node); 3096 3097 ------------------- 3098 -- Process_Stmts -- 3099 ------------------- 3100 3101 procedure Process_Stmts (Stmts : List_Id) is 3102 Stmt : Node_Id; 3103 begin 3104 Stmt := First (Stmts); 3105 while Present (Stmt) loop 3106 Process_Nodes (Stmt); 3107 Next (Stmt); 3108 end loop; 3109 end Process_Stmts; 3110 3111 -- Start of processing for Protected_Component_Ref 3112 3113 begin 3114 -- Get the type size 3115 3116 if Known_Static_Esize (Comp_Type) then 3117 Typ_Size := UI_To_Int (Esize (Comp_Type)); 3118 3119 -- If the Esize (Object_Size) is unknown at compile time, look at 3120 -- the RM_Size (Value_Size) since it may have been set by an 3121 -- explicit representation clause. 3122 3123 elsif Known_Static_RM_Size (Comp_Type) then 3124 Typ_Size := UI_To_Int (RM_Size (Comp_Type)); 3125 3126 -- Should not happen since this has already been checked in 3127 -- Allows_Lock_Free_Implementation (see Sem_Ch9). 3128 3129 else 3130 raise Program_Error; 3131 end if; 3132 3133 -- Retrieve all relevant atomic routines and types 3134 3135 case Typ_Size is 3136 when 8 => 3137 Try_Write := RTE (RE_Lock_Free_Try_Write_8); 3138 Read := RTE (RE_Lock_Free_Read_8); 3139 Unsigned := RTE (RE_Uint8); 3140 3141 when 16 => 3142 Try_Write := RTE (RE_Lock_Free_Try_Write_16); 3143 Read := RTE (RE_Lock_Free_Read_16); 3144 Unsigned := RTE (RE_Uint16); 3145 3146 when 32 => 3147 Try_Write := RTE (RE_Lock_Free_Try_Write_32); 3148 Read := RTE (RE_Lock_Free_Read_32); 3149 Unsigned := RTE (RE_Uint32); 3150 3151 when 64 => 3152 Try_Write := RTE (RE_Lock_Free_Try_Write_64); 3153 Read := RTE (RE_Lock_Free_Read_64); 3154 Unsigned := RTE (RE_Uint64); 3155 3156 when others => 3157 raise Program_Error; 3158 end case; 3159 3160 -- Generate: 3161 -- Expected_Comp : constant Comp_Type := 3162 -- Comp_Type 3163 -- (System.Atomic_Primitives.Lock_Free_Read_N 3164 -- (_Object.Comp'Address)); 3165 3166 Expected_Comp := 3167 Make_Defining_Identifier (Loc, 3168 New_External_Name (Chars (Comp), Suffix => "_saved")); 3169 3170 Decl := 3171 Make_Object_Declaration (Loc, 3172 Defining_Identifier => Expected_Comp, 3173 Object_Definition => New_Occurrence_Of (Comp_Type, Loc), 3174 Constant_Present => True, 3175 Expression => 3176 Unchecked_Convert_To (Comp_Type, 3177 Make_Function_Call (Loc, 3178 Name => New_Occurrence_Of (Read, Loc), 3179 Parameter_Associations => New_List ( 3180 Make_Attribute_Reference (Loc, 3181 Prefix => Relocate_Node (Comp_Sel_Nam), 3182 Attribute_Name => Name_Address))))); 3183 3184 -- Protected procedures 3185 3186 if Is_Procedure then 3187 -- Move the original declarations inside the generated block 3188 3189 Block_Decls := Decls; 3190 3191 -- Reset the declarations list of the protected procedure to 3192 -- contain only Decl. 3193 3194 Decls := New_List (Decl); 3195 3196 -- Generate: 3197 -- Desired_Comp : Comp_Type := Expected_Comp; 3198 3199 Desired_Comp := 3200 Make_Defining_Identifier (Loc, 3201 New_External_Name (Chars (Comp), Suffix => "_current")); 3202 3203 -- Insert the declarations of Expected_Comp and Desired_Comp in 3204 -- the block declarations right before the renaming of the 3205 -- protected component. 3206 3207 Insert_Before (Comp_Decl, 3208 Make_Object_Declaration (Loc, 3209 Defining_Identifier => Desired_Comp, 3210 Object_Definition => New_Occurrence_Of (Comp_Type, Loc), 3211 Expression => 3212 New_Occurrence_Of (Expected_Comp, Loc))); 3213 3214 -- Protected function 3215 3216 else 3217 Desired_Comp := Expected_Comp; 3218 3219 -- Insert the declaration of Expected_Comp in the function 3220 -- declarations right before the renaming of the protected 3221 -- component. 3222 3223 Insert_Before (Comp_Decl, Decl); 3224 end if; 3225 3226 -- Rewrite the protected component renaming declaration to be a 3227 -- renaming of Desired_Comp. 3228 3229 -- Generate: 3230 -- Comp : Comp_Type renames Desired_Comp; 3231 3232 Rewrite (Comp_Decl, 3233 Make_Object_Renaming_Declaration (Loc, 3234 Defining_Identifier => 3235 Defining_Identifier (Comp_Decl), 3236 Subtype_Mark => 3237 New_Occurrence_Of (Comp_Type, Loc), 3238 Name => 3239 New_Occurrence_Of (Desired_Comp, Loc))); 3240 3241 -- Wrap any return or raise statements in Stmts in same the manner 3242 -- described in Process_Stmts. 3243 3244 Process_Stmts (Stmts); 3245 3246 -- Generate: 3247 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N 3248 -- (_Object.Comp'Address, 3249 -- Interfaces.Unsigned_N (Expected_Comp), 3250 -- Interfaces.Unsigned_N (Desired_Comp)) 3251 3252 if Is_Procedure then 3253 Stmt := 3254 Make_Exit_Statement (Loc, 3255 Condition => 3256 Make_Function_Call (Loc, 3257 Name => 3258 New_Occurrence_Of (Try_Write, Loc), 3259 Parameter_Associations => New_List ( 3260 Make_Attribute_Reference (Loc, 3261 Prefix => Relocate_Node (Comp_Sel_Nam), 3262 Attribute_Name => Name_Address), 3263 3264 Unchecked_Convert_To (Unsigned, 3265 New_Occurrence_Of (Expected_Comp, Loc)), 3266 3267 Unchecked_Convert_To (Unsigned, 3268 New_Occurrence_Of (Desired_Comp, Loc))))); 3269 3270 -- Small optimization: transform the default return statement 3271 -- of a procedure into the atomic exit statement. 3272 3273 if Nkind (Last (Stmts)) = N_Simple_Return_Statement then 3274 Rewrite (Last (Stmts), Stmt); 3275 else 3276 Append_To (Stmts, Stmt); 3277 end if; 3278 end if; 3279 3280 -- Create the declaration of the label used to skip the rest of 3281 -- the source statements when the object state changes. 3282 3283 if Present (Label_Id) then 3284 Label := Make_Label (Loc, Label_Id); 3285 Append_To (Decls, 3286 Make_Implicit_Label_Declaration (Loc, 3287 Defining_Identifier => Entity (Label_Id), 3288 Label_Construct => Label)); 3289 Append_To (Stmts, Label); 3290 end if; 3291 3292 -- Generate: 3293 -- loop 3294 -- declare 3295 -- <Decls> 3296 -- begin 3297 -- <Stmts> 3298 -- end; 3299 -- end loop; 3300 3301 if Is_Procedure then 3302 Stmts := 3303 New_List ( 3304 Make_Loop_Statement (Loc, 3305 Statements => New_List ( 3306 Make_Block_Statement (Loc, 3307 Declarations => Block_Decls, 3308 Handled_Statement_Sequence => 3309 Make_Handled_Sequence_Of_Statements (Loc, 3310 Statements => Stmts))), 3311 End_Label => Empty)); 3312 end if; 3313 3314 Hand_Stmt_Seq := 3315 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts); 3316 end Protected_Component_Ref; 3317 end if; 3318 3319 -- Make an unprotected version of the subprogram for use within the same 3320 -- object, with new name and extra parameter representing the object. 3321 3322 return 3323 Make_Subprogram_Body (Loc, 3324 Specification => 3325 Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode), 3326 Declarations => Decls, 3327 Handled_Statement_Sequence => Hand_Stmt_Seq); 3328 end Build_Lock_Free_Unprotected_Subprogram_Body; 3329 3330 ------------------------- 3331 -- Build_Master_Entity -- 3332 ------------------------- 3333 3334 procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is 3335 Loc : constant Source_Ptr := Sloc (Obj_Or_Typ); 3336 Context : Node_Id; 3337 Context_Id : Entity_Id; 3338 Decl : Node_Id; 3339 Decls : List_Id; 3340 Par : Node_Id; 3341 3342 begin 3343 if Is_Itype (Obj_Or_Typ) then 3344 Par := Associated_Node_For_Itype (Obj_Or_Typ); 3345 else 3346 Par := Parent (Obj_Or_Typ); 3347 end if; 3348 3349 -- When creating a master for a record component which is either a task 3350 -- or access-to-task, the enclosing record is the master scope and the 3351 -- proper insertion point is the component list. 3352 3353 if Is_Record_Type (Current_Scope) then 3354 Context := Par; 3355 Context_Id := Current_Scope; 3356 Decls := List_Containing (Context); 3357 3358 -- Default case for object declarations and access types. Note that the 3359 -- context is updated to the nearest enclosing body, block, package, or 3360 -- return statement. 3361 3362 else 3363 Find_Enclosing_Context (Par, Context, Context_Id, Decls); 3364 end if; 3365 3366 -- Nothing to do if the context already has a master 3367 3368 if Has_Master_Entity (Context_Id) then 3369 return; 3370 3371 -- Nothing to do if tasks or tasking hierarchies are prohibited 3372 3373 elsif Restriction_Active (No_Tasking) 3374 or else Restriction_Active (No_Task_Hierarchy) 3375 then 3376 return; 3377 end if; 3378 3379 -- Create a master, generate: 3380 -- _Master : constant Master_Id := Current_Master.all; 3381 3382 Decl := 3383 Make_Object_Declaration (Loc, 3384 Defining_Identifier => 3385 Make_Defining_Identifier (Loc, Name_uMaster), 3386 Constant_Present => True, 3387 Object_Definition => New_Occurrence_Of (RTE (RE_Master_Id), Loc), 3388 Expression => 3389 Make_Explicit_Dereference (Loc, 3390 New_Occurrence_Of (RTE (RE_Current_Master), Loc))); 3391 3392 -- The master is inserted at the start of the declarative list of the 3393 -- context. 3394 3395 Prepend_To (Decls, Decl); 3396 3397 -- In certain cases where transient scopes are involved, the immediate 3398 -- scope is not always the proper master scope. Ensure that the master 3399 -- declaration and entity appear in the same context. 3400 3401 if Context_Id /= Current_Scope then 3402 Push_Scope (Context_Id); 3403 Analyze (Decl); 3404 Pop_Scope; 3405 else 3406 Analyze (Decl); 3407 end if; 3408 3409 -- Mark the enclosing scope and its associated construct as being task 3410 -- masters. 3411 3412 Set_Has_Master_Entity (Context_Id); 3413 3414 while Present (Context) 3415 and then Nkind (Context) /= N_Compilation_Unit 3416 loop 3417 if Nkind_In (Context, N_Block_Statement, 3418 N_Subprogram_Body, 3419 N_Task_Body) 3420 then 3421 Set_Is_Task_Master (Context); 3422 exit; 3423 3424 elsif Nkind (Parent (Context)) = N_Subunit then 3425 Context := Corresponding_Stub (Parent (Context)); 3426 end if; 3427 3428 Context := Parent (Context); 3429 end loop; 3430 end Build_Master_Entity; 3431 3432 --------------------------- 3433 -- Build_Master_Renaming -- 3434 --------------------------- 3435 3436 procedure Build_Master_Renaming 3437 (Ptr_Typ : Entity_Id; 3438 Ins_Nod : Node_Id := Empty) 3439 is 3440 Loc : constant Source_Ptr := Sloc (Ptr_Typ); 3441 Context : Node_Id; 3442 Master_Decl : Node_Id; 3443 Master_Id : Entity_Id; 3444 3445 begin 3446 -- Nothing to do if tasks or tasking hierarchies are prohibited 3447 3448 if Restriction_Active (No_Tasking) 3449 or else Restriction_Active (No_Task_Hierarchy) 3450 then 3451 return; 3452 end if; 3453 3454 -- Determine the proper context to insert the master renaming 3455 3456 if Present (Ins_Nod) then 3457 Context := Ins_Nod; 3458 elsif Is_Itype (Ptr_Typ) then 3459 Context := Associated_Node_For_Itype (Ptr_Typ); 3460 else 3461 Context := Parent (Ptr_Typ); 3462 end if; 3463 3464 -- Generate: 3465 -- <Ptr_Typ>M : Master_Id renames _Master; 3466 3467 Master_Id := 3468 Make_Defining_Identifier (Loc, 3469 New_External_Name (Chars (Ptr_Typ), 'M')); 3470 3471 Master_Decl := 3472 Make_Object_Renaming_Declaration (Loc, 3473 Defining_Identifier => Master_Id, 3474 Subtype_Mark => New_Occurrence_Of (RTE (RE_Master_Id), Loc), 3475 Name => Make_Identifier (Loc, Name_uMaster)); 3476 3477 Insert_Action (Context, Master_Decl); 3478 3479 -- The renamed master now services the access type 3480 3481 Set_Master_Id (Ptr_Typ, Master_Id); 3482 end Build_Master_Renaming; 3483 3484 ----------------------------------------- 3485 -- Build_Private_Protected_Declaration -- 3486 ----------------------------------------- 3487 3488 function Build_Private_Protected_Declaration 3489 (N : Node_Id) return Entity_Id 3490 is 3491 procedure Analyze_Pragmas (From : Node_Id); 3492 -- Analyze all pragmas which follow arbitrary node From 3493 3494 procedure Move_Pragmas (From : Node_Id; To : Node_Id); 3495 -- Find all suitable source pragmas at the top of subprogram body From's 3496 -- declarations and insert them after arbitrary node To. 3497 3498 --------------------- 3499 -- Analyze_Pragmas -- 3500 --------------------- 3501 3502 procedure Analyze_Pragmas (From : Node_Id) is 3503 Decl : Node_Id; 3504 3505 begin 3506 Decl := Next (From); 3507 while Present (Decl) loop 3508 if Nkind (Decl) = N_Pragma then 3509 Analyze_Pragma (Decl); 3510 3511 -- No candidate pragmas are available for analysis 3512 3513 else 3514 exit; 3515 end if; 3516 3517 Next (Decl); 3518 end loop; 3519 end Analyze_Pragmas; 3520 3521 ------------------ 3522 -- Move_Pragmas -- 3523 ------------------ 3524 3525 procedure Move_Pragmas (From : Node_Id; To : Node_Id) is 3526 Decl : Node_Id; 3527 Insert_Nod : Node_Id; 3528 Next_Decl : Node_Id; 3529 3530 begin 3531 pragma Assert (Nkind (From) = N_Subprogram_Body); 3532 3533 -- The pragmas are moved in an order-preserving fashion 3534 3535 Insert_Nod := To; 3536 3537 -- Inspect the declarations of the subprogram body and relocate all 3538 -- candidate pragmas. 3539 3540 Decl := First (Declarations (From)); 3541 while Present (Decl) loop 3542 3543 -- Preserve the following declaration for iteration purposes, due 3544 -- to possible relocation of a pragma. 3545 3546 Next_Decl := Next (Decl); 3547 3548 if Nkind (Decl) = N_Pragma then 3549 Remove (Decl); 3550 Insert_After (Insert_Nod, Decl); 3551 Insert_Nod := Decl; 3552 3553 -- Skip internally generated code 3554 3555 elsif not Comes_From_Source (Decl) then 3556 null; 3557 3558 -- No candidate pragmas are available for relocation 3559 3560 else 3561 exit; 3562 end if; 3563 3564 Decl := Next_Decl; 3565 end loop; 3566 end Move_Pragmas; 3567 3568 -- Local variables 3569 3570 Body_Id : constant Entity_Id := Defining_Entity (N); 3571 Loc : constant Source_Ptr := Sloc (N); 3572 Decl : Node_Id; 3573 Formal : Entity_Id; 3574 Formals : List_Id; 3575 Spec : Node_Id; 3576 Spec_Id : Entity_Id; 3577 3578 -- Start of processing for Build_Private_Protected_Declaration 3579 3580 begin 3581 Formal := First_Formal (Body_Id); 3582 3583 -- The protected operation always has at least one formal, namely the 3584 -- object itself, but it is only placed in the parameter list if 3585 -- expansion is enabled. 3586 3587 if Present (Formal) or else Expander_Active then 3588 Formals := Copy_Parameter_List (Body_Id); 3589 else 3590 Formals := No_List; 3591 end if; 3592 3593 Spec_Id := 3594 Make_Defining_Identifier (Sloc (Body_Id), 3595 Chars => Chars (Body_Id)); 3596 3597 -- Indicate that the entity comes from source, to ensure that cross- 3598 -- reference information is properly generated. The body itself is 3599 -- rewritten during expansion, and the body entity will not appear in 3600 -- calls to the operation. 3601 3602 Set_Comes_From_Source (Spec_Id, True); 3603 3604 if Nkind (Specification (N)) = N_Procedure_Specification then 3605 Spec := 3606 Make_Procedure_Specification (Loc, 3607 Defining_Unit_Name => Spec_Id, 3608 Parameter_Specifications => Formals); 3609 else 3610 Spec := 3611 Make_Function_Specification (Loc, 3612 Defining_Unit_Name => Spec_Id, 3613 Parameter_Specifications => Formals, 3614 Result_Definition => 3615 New_Occurrence_Of (Etype (Body_Id), Loc)); 3616 end if; 3617 3618 Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); 3619 Set_Corresponding_Body (Decl, Body_Id); 3620 Set_Corresponding_Spec (N, Spec_Id); 3621 3622 Insert_Before (N, Decl); 3623 3624 -- Associate all aspects and pragmas of the body with the spec. This 3625 -- ensures that these annotations apply to the initial declaration of 3626 -- the subprogram body. 3627 3628 Move_Aspects (From => N, To => Decl); 3629 Move_Pragmas (From => N, To => Decl); 3630 3631 Analyze (Decl); 3632 3633 -- The analysis of the spec may generate pragmas which require manual 3634 -- analysis. Since the generation of the spec and the relocation of the 3635 -- annotations is driven by the expansion of the stand-alone body, the 3636 -- pragmas will not be analyzed in a timely manner. Do this now. 3637 3638 Analyze_Pragmas (Decl); 3639 3640 Set_Convention (Spec_Id, Convention_Protected); 3641 Set_Has_Completion (Spec_Id); 3642 3643 return Spec_Id; 3644 end Build_Private_Protected_Declaration; 3645 3646 --------------------------- 3647 -- Build_Protected_Entry -- 3648 --------------------------- 3649 3650 function Build_Protected_Entry 3651 (N : Node_Id; 3652 Ent : Entity_Id; 3653 Pid : Node_Id) return Node_Id 3654 is 3655 Bod_Decls : constant List_Id := New_List; 3656 Decls : constant List_Id := Declarations (N); 3657 End_Lab : constant Node_Id := 3658 End_Label (Handled_Statement_Sequence (N)); 3659 End_Loc : constant Source_Ptr := 3660 Sloc (Last (Statements (Handled_Statement_Sequence (N)))); 3661 -- Used for the generated call to Complete_Entry_Body 3662 3663 Loc : constant Source_Ptr := Sloc (N); 3664 3665 Bod_Id : Entity_Id; 3666 Bod_Spec : Node_Id; 3667 Bod_Stmts : List_Id; 3668 Complete : Node_Id; 3669 Ohandle : Node_Id; 3670 Proc_Body : Node_Id; 3671 3672 EH_Loc : Source_Ptr; 3673 -- Used for the exception handler, inserted at end of the body 3674 3675 begin 3676 -- Set the source location on the exception handler only when debugging 3677 -- the expanded code (see Make_Implicit_Exception_Handler). 3678 3679 if Debug_Generated_Code then 3680 EH_Loc := End_Loc; 3681 3682 -- Otherwise the inserted code should not be visible to the debugger 3683 3684 else 3685 EH_Loc := No_Location; 3686 end if; 3687 3688 Bod_Id := 3689 Make_Defining_Identifier (Loc, 3690 Chars => Chars (Protected_Body_Subprogram (Ent))); 3691 Bod_Spec := Build_Protected_Entry_Specification (Loc, Bod_Id, Empty); 3692 3693 -- Add the following declarations: 3694 3695 -- type poVP is access poV; 3696 -- _object : poVP := poVP (_O); 3697 3698 -- where _O is the formal parameter associated with the concurrent 3699 -- object. These declarations are needed for Complete_Entry_Body. 3700 3701 Add_Object_Pointer (Loc, Pid, Bod_Decls); 3702 3703 -- Add renamings for all formals, the Protection object, discriminals, 3704 -- privals and the entry index constant for use by debugger. 3705 3706 Add_Formal_Renamings (Bod_Spec, Bod_Decls, Ent, Loc); 3707 Debug_Private_Data_Declarations (Decls); 3708 3709 -- Put the declarations and the statements from the entry 3710 3711 Bod_Stmts := 3712 New_List ( 3713 Make_Block_Statement (Loc, 3714 Declarations => Decls, 3715 Handled_Statement_Sequence => Handled_Statement_Sequence (N))); 3716 3717 case Corresponding_Runtime_Package (Pid) is 3718 when System_Tasking_Protected_Objects_Entries => 3719 Append_To (Bod_Stmts, 3720 Make_Procedure_Call_Statement (End_Loc, 3721 Name => 3722 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc), 3723 Parameter_Associations => New_List ( 3724 Make_Attribute_Reference (End_Loc, 3725 Prefix => 3726 Make_Selected_Component (End_Loc, 3727 Prefix => 3728 Make_Identifier (End_Loc, Name_uObject), 3729 Selector_Name => 3730 Make_Identifier (End_Loc, Name_uObject)), 3731 Attribute_Name => Name_Unchecked_Access)))); 3732 3733 when System_Tasking_Protected_Objects_Single_Entry => 3734 3735 -- Historically, a call to Complete_Single_Entry_Body was 3736 -- inserted, but it was a null procedure. 3737 3738 null; 3739 3740 when others => 3741 raise Program_Error; 3742 end case; 3743 3744 -- When exceptions cannot be propagated, we never need to call 3745 -- Exception_Complete_Entry_Body. 3746 3747 if No_Exception_Handlers_Set then 3748 return 3749 Make_Subprogram_Body (Loc, 3750 Specification => Bod_Spec, 3751 Declarations => Bod_Decls, 3752 Handled_Statement_Sequence => 3753 Make_Handled_Sequence_Of_Statements (Loc, 3754 Statements => Bod_Stmts, 3755 End_Label => End_Lab)); 3756 3757 else 3758 Ohandle := Make_Others_Choice (Loc); 3759 Set_All_Others (Ohandle); 3760 3761 case Corresponding_Runtime_Package (Pid) is 3762 when System_Tasking_Protected_Objects_Entries => 3763 Complete := 3764 New_Occurrence_Of 3765 (RTE (RE_Exceptional_Complete_Entry_Body), Loc); 3766 3767 when System_Tasking_Protected_Objects_Single_Entry => 3768 Complete := 3769 New_Occurrence_Of 3770 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); 3771 3772 when others => 3773 raise Program_Error; 3774 end case; 3775 3776 -- Establish link between subprogram body entity and source entry 3777 3778 Set_Corresponding_Protected_Entry (Bod_Id, Ent); 3779 3780 -- Create body of entry procedure. The renaming declarations are 3781 -- placed ahead of the block that contains the actual entry body. 3782 3783 Proc_Body := 3784 Make_Subprogram_Body (Loc, 3785 Specification => Bod_Spec, 3786 Declarations => Bod_Decls, 3787 Handled_Statement_Sequence => 3788 Make_Handled_Sequence_Of_Statements (Loc, 3789 Statements => Bod_Stmts, 3790 End_Label => End_Lab, 3791 Exception_Handlers => New_List ( 3792 Make_Implicit_Exception_Handler (EH_Loc, 3793 Exception_Choices => New_List (Ohandle), 3794 3795 Statements => New_List ( 3796 Make_Procedure_Call_Statement (EH_Loc, 3797 Name => Complete, 3798 Parameter_Associations => New_List ( 3799 Make_Attribute_Reference (EH_Loc, 3800 Prefix => 3801 Make_Selected_Component (EH_Loc, 3802 Prefix => 3803 Make_Identifier (EH_Loc, Name_uObject), 3804 Selector_Name => 3805 Make_Identifier (EH_Loc, Name_uObject)), 3806 Attribute_Name => Name_Unchecked_Access), 3807 3808 Make_Function_Call (EH_Loc, 3809 Name => 3810 New_Occurrence_Of 3811 (RTE (RE_Get_GNAT_Exception), Loc))))))))); 3812 3813 Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent)); 3814 return Proc_Body; 3815 end if; 3816 end Build_Protected_Entry; 3817 3818 ----------------------------------------- 3819 -- Build_Protected_Entry_Specification -- 3820 ----------------------------------------- 3821 3822 function Build_Protected_Entry_Specification 3823 (Loc : Source_Ptr; 3824 Def_Id : Entity_Id; 3825 Ent_Id : Entity_Id) return Node_Id 3826 is 3827 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP); 3828 3829 begin 3830 Set_Debug_Info_Needed (Def_Id); 3831 3832 if Present (Ent_Id) then 3833 Append_Elmt (P, Accept_Address (Ent_Id)); 3834 end if; 3835 3836 return 3837 Make_Procedure_Specification (Loc, 3838 Defining_Unit_Name => Def_Id, 3839 Parameter_Specifications => New_List ( 3840 Make_Parameter_Specification (Loc, 3841 Defining_Identifier => 3842 Make_Defining_Identifier (Loc, Name_uO), 3843 Parameter_Type => 3844 New_Occurrence_Of (RTE (RE_Address), Loc)), 3845 3846 Make_Parameter_Specification (Loc, 3847 Defining_Identifier => P, 3848 Parameter_Type => 3849 New_Occurrence_Of (RTE (RE_Address), Loc)), 3850 3851 Make_Parameter_Specification (Loc, 3852 Defining_Identifier => 3853 Make_Defining_Identifier (Loc, Name_uE), 3854 Parameter_Type => 3855 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)))); 3856 end Build_Protected_Entry_Specification; 3857 3858 -------------------------- 3859 -- Build_Protected_Spec -- 3860 -------------------------- 3861 3862 function Build_Protected_Spec 3863 (N : Node_Id; 3864 Obj_Type : Entity_Id; 3865 Ident : Entity_Id; 3866 Unprotected : Boolean := False) return List_Id 3867 is 3868 Loc : constant Source_Ptr := Sloc (N); 3869 Decl : Node_Id; 3870 Formal : Entity_Id; 3871 New_Plist : List_Id; 3872 New_Param : Node_Id; 3873 3874 begin 3875 New_Plist := New_List; 3876 3877 Formal := First_Formal (Ident); 3878 while Present (Formal) loop 3879 New_Param := 3880 Make_Parameter_Specification (Loc, 3881 Defining_Identifier => 3882 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 3883 Aliased_Present => Aliased_Present (Parent (Formal)), 3884 In_Present => In_Present (Parent (Formal)), 3885 Out_Present => Out_Present (Parent (Formal)), 3886 Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc)); 3887 3888 if Unprotected then 3889 Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); 3890 end if; 3891 3892 Append (New_Param, New_Plist); 3893 Next_Formal (Formal); 3894 end loop; 3895 3896 -- If the subprogram is a procedure and the context is not an access 3897 -- to protected subprogram, the parameter is in-out. Otherwise it is 3898 -- an in parameter. 3899 3900 Decl := 3901 Make_Parameter_Specification (Loc, 3902 Defining_Identifier => 3903 Make_Defining_Identifier (Loc, Name_uObject), 3904 In_Present => True, 3905 Out_Present => 3906 (Etype (Ident) = Standard_Void_Type 3907 and then not Is_RTE (Obj_Type, RE_Address)), 3908 Parameter_Type => 3909 New_Occurrence_Of (Obj_Type, Loc)); 3910 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 3911 Prepend_To (New_Plist, Decl); 3912 3913 return New_Plist; 3914 end Build_Protected_Spec; 3915 3916 --------------------------------------- 3917 -- Build_Protected_Sub_Specification -- 3918 --------------------------------------- 3919 3920 function Build_Protected_Sub_Specification 3921 (N : Node_Id; 3922 Prot_Typ : Entity_Id; 3923 Mode : Subprogram_Protection_Mode) return Node_Id 3924 is 3925 Loc : constant Source_Ptr := Sloc (N); 3926 Decl : Node_Id; 3927 Def_Id : Entity_Id; 3928 New_Id : Entity_Id; 3929 New_Plist : List_Id; 3930 New_Spec : Node_Id; 3931 3932 Append_Chr : constant array (Subprogram_Protection_Mode) of Character := 3933 (Dispatching_Mode => ' ', 3934 Protected_Mode => 'P', 3935 Unprotected_Mode => 'N'); 3936 3937 begin 3938 if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body 3939 then 3940 Decl := Unit_Declaration_Node (Corresponding_Spec (N)); 3941 else 3942 Decl := N; 3943 end if; 3944 3945 Def_Id := Defining_Unit_Name (Specification (Decl)); 3946 3947 New_Plist := 3948 Build_Protected_Spec 3949 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id, 3950 Mode = Unprotected_Mode); 3951 New_Id := 3952 Make_Defining_Identifier (Loc, 3953 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); 3954 3955 -- Reference the original nondispatching subprogram since the analysis 3956 -- of the object.operation notation may need its original name (see 3957 -- Sem_Ch4.Names_Match). 3958 3959 if Mode = Dispatching_Mode then 3960 Set_Ekind (New_Id, Ekind (Def_Id)); 3961 Set_Original_Protected_Subprogram (New_Id, Def_Id); 3962 end if; 3963 3964 -- Link the protected or unprotected version to the original subprogram 3965 -- it emulates. 3966 3967 Set_Ekind (New_Id, Ekind (Def_Id)); 3968 Set_Protected_Subprogram (New_Id, Def_Id); 3969 3970 -- The unprotected operation carries the user code, and debugging 3971 -- information must be generated for it, even though this spec does 3972 -- not come from source. It is also convenient to allow gdb to step 3973 -- into the protected operation, even though it only contains lock/ 3974 -- unlock calls. 3975 3976 Set_Debug_Info_Needed (New_Id); 3977 3978 -- If a pragma Eliminate applies to the source entity, the internal 3979 -- subprograms will be eliminated as well. 3980 3981 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id)); 3982 3983 if Nkind (Specification (Decl)) = N_Procedure_Specification then 3984 New_Spec := 3985 Make_Procedure_Specification (Loc, 3986 Defining_Unit_Name => New_Id, 3987 Parameter_Specifications => New_Plist); 3988 3989 -- Create a new specification for the anonymous subprogram type 3990 3991 else 3992 New_Spec := 3993 Make_Function_Specification (Loc, 3994 Defining_Unit_Name => New_Id, 3995 Parameter_Specifications => New_Plist, 3996 Result_Definition => 3997 Copy_Result_Type (Result_Definition (Specification (Decl)))); 3998 3999 Set_Return_Present (Defining_Unit_Name (New_Spec)); 4000 end if; 4001 4002 return New_Spec; 4003 end Build_Protected_Sub_Specification; 4004 4005 ------------------------------------- 4006 -- Build_Protected_Subprogram_Body -- 4007 ------------------------------------- 4008 4009 function Build_Protected_Subprogram_Body 4010 (N : Node_Id; 4011 Pid : Node_Id; 4012 N_Op_Spec : Node_Id) return Node_Id 4013 is 4014 Exc_Safe : constant Boolean := not Might_Raise (N); 4015 -- True if N cannot raise an exception 4016 4017 Loc : constant Source_Ptr := Sloc (N); 4018 Op_Spec : constant Node_Id := Specification (N); 4019 P_Op_Spec : constant Node_Id := 4020 Build_Protected_Sub_Specification (N, Pid, Protected_Mode); 4021 4022 Lock_Kind : RE_Id; 4023 Lock_Name : Node_Id; 4024 Lock_Stmt : Node_Id; 4025 Object_Parm : Node_Id; 4026 Pformal : Node_Id; 4027 R : Node_Id; 4028 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning 4029 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning 4030 Stmts : List_Id; 4031 Sub_Body : Node_Id; 4032 Uactuals : List_Id; 4033 Unprot_Call : Node_Id; 4034 4035 begin 4036 -- Build a list of the formal parameters of the protected version of 4037 -- the subprogram to use as the actual parameters of the unprotected 4038 -- version. 4039 4040 Uactuals := New_List; 4041 Pformal := First (Parameter_Specifications (P_Op_Spec)); 4042 while Present (Pformal) loop 4043 Append_To (Uactuals, 4044 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal)))); 4045 Next (Pformal); 4046 end loop; 4047 4048 -- Make a call to the unprotected version of the subprogram built above 4049 -- for use by the protected version built below. 4050 4051 if Nkind (Op_Spec) = N_Function_Specification then 4052 if Exc_Safe then 4053 R := Make_Temporary (Loc, 'R'); 4054 4055 Unprot_Call := 4056 Make_Object_Declaration (Loc, 4057 Defining_Identifier => R, 4058 Constant_Present => True, 4059 Object_Definition => 4060 New_Copy (Result_Definition (N_Op_Spec)), 4061 Expression => 4062 Make_Function_Call (Loc, 4063 Name => 4064 Make_Identifier (Loc, 4065 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 4066 Parameter_Associations => Uactuals)); 4067 4068 Return_Stmt := 4069 Make_Simple_Return_Statement (Loc, 4070 Expression => New_Occurrence_Of (R, Loc)); 4071 4072 else 4073 Unprot_Call := 4074 Make_Simple_Return_Statement (Loc, 4075 Expression => 4076 Make_Function_Call (Loc, 4077 Name => 4078 Make_Identifier (Loc, 4079 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 4080 Parameter_Associations => Uactuals)); 4081 end if; 4082 4083 Lock_Kind := RE_Lock_Read_Only; 4084 4085 else 4086 Unprot_Call := 4087 Make_Procedure_Call_Statement (Loc, 4088 Name => 4089 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), 4090 Parameter_Associations => Uactuals); 4091 4092 Lock_Kind := RE_Lock; 4093 end if; 4094 4095 -- Wrap call in block that will be covered by an at_end handler 4096 4097 if not Exc_Safe then 4098 Unprot_Call := 4099 Make_Block_Statement (Loc, 4100 Handled_Statement_Sequence => 4101 Make_Handled_Sequence_Of_Statements (Loc, 4102 Statements => New_List (Unprot_Call))); 4103 end if; 4104 4105 -- Make the protected subprogram body. This locks the protected 4106 -- object and calls the unprotected version of the subprogram. 4107 4108 case Corresponding_Runtime_Package (Pid) is 4109 when System_Tasking_Protected_Objects_Entries => 4110 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc); 4111 4112 when System_Tasking_Protected_Objects_Single_Entry => 4113 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc); 4114 4115 when System_Tasking_Protected_Objects => 4116 Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc); 4117 4118 when others => 4119 raise Program_Error; 4120 end case; 4121 4122 Object_Parm := 4123 Make_Attribute_Reference (Loc, 4124 Prefix => 4125 Make_Selected_Component (Loc, 4126 Prefix => Make_Identifier (Loc, Name_uObject), 4127 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4128 Attribute_Name => Name_Unchecked_Access); 4129 4130 Lock_Stmt := 4131 Make_Procedure_Call_Statement (Loc, 4132 Name => Lock_Name, 4133 Parameter_Associations => New_List (Object_Parm)); 4134 4135 if Abort_Allowed then 4136 Stmts := New_List ( 4137 Build_Runtime_Call (Loc, RE_Abort_Defer), 4138 Lock_Stmt); 4139 4140 else 4141 Stmts := New_List (Lock_Stmt); 4142 end if; 4143 4144 if not Exc_Safe then 4145 Append (Unprot_Call, Stmts); 4146 else 4147 if Nkind (Op_Spec) = N_Function_Specification then 4148 Pre_Stmts := Stmts; 4149 Stmts := Empty_List; 4150 else 4151 Append (Unprot_Call, Stmts); 4152 end if; 4153 4154 -- Historical note: Previously, call to the cleanup was inserted 4155 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup, 4156 -- which is also shared by the 'not Exc_Safe' path. 4157 4158 Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts); 4159 4160 if Nkind (Op_Spec) = N_Function_Specification then 4161 Append_To (Stmts, Return_Stmt); 4162 Append_To (Pre_Stmts, 4163 Make_Block_Statement (Loc, 4164 Declarations => New_List (Unprot_Call), 4165 Handled_Statement_Sequence => 4166 Make_Handled_Sequence_Of_Statements (Loc, 4167 Statements => Stmts))); 4168 Stmts := Pre_Stmts; 4169 end if; 4170 end if; 4171 4172 Sub_Body := 4173 Make_Subprogram_Body (Loc, 4174 Declarations => Empty_List, 4175 Specification => P_Op_Spec, 4176 Handled_Statement_Sequence => 4177 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); 4178 4179 -- Mark this subprogram as a protected subprogram body so that the 4180 -- cleanup will be inserted. This is done only in the 'not Exc_Safe' 4181 -- path as otherwise the cleanup has already been inserted. 4182 4183 if not Exc_Safe then 4184 Set_Is_Protected_Subprogram_Body (Sub_Body); 4185 end if; 4186 4187 return Sub_Body; 4188 end Build_Protected_Subprogram_Body; 4189 4190 ------------------------------------- 4191 -- Build_Protected_Subprogram_Call -- 4192 ------------------------------------- 4193 4194 procedure Build_Protected_Subprogram_Call 4195 (N : Node_Id; 4196 Name : Node_Id; 4197 Rec : Node_Id; 4198 External : Boolean := True) 4199 is 4200 Loc : constant Source_Ptr := Sloc (N); 4201 Sub : constant Entity_Id := Entity (Name); 4202 New_Sub : Node_Id; 4203 Params : List_Id; 4204 4205 begin 4206 if External then 4207 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc); 4208 else 4209 New_Sub := 4210 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc); 4211 end if; 4212 4213 if Present (Parameter_Associations (N)) then 4214 Params := New_Copy_List_Tree (Parameter_Associations (N)); 4215 else 4216 Params := New_List; 4217 end if; 4218 4219 -- If the type is an untagged derived type, convert to the root type, 4220 -- which is the one on which the operations are defined. 4221 4222 if Nkind (Rec) = N_Unchecked_Type_Conversion 4223 and then not Is_Tagged_Type (Etype (Rec)) 4224 and then Is_Derived_Type (Etype (Rec)) 4225 then 4226 Set_Etype (Rec, Root_Type (Etype (Rec))); 4227 Set_Subtype_Mark (Rec, 4228 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N))); 4229 end if; 4230 4231 Prepend (Rec, Params); 4232 4233 if Ekind (Sub) = E_Procedure then 4234 Rewrite (N, 4235 Make_Procedure_Call_Statement (Loc, 4236 Name => New_Sub, 4237 Parameter_Associations => Params)); 4238 4239 else 4240 pragma Assert (Ekind (Sub) = E_Function); 4241 Rewrite (N, 4242 Make_Function_Call (Loc, 4243 Name => New_Sub, 4244 Parameter_Associations => Params)); 4245 4246 -- Preserve type of call for subsequent processing (required for 4247 -- call to Wrap_Transient_Expression in the case of a shared passive 4248 -- protected). 4249 4250 Set_Etype (N, Etype (New_Sub)); 4251 end if; 4252 4253 if External 4254 and then Nkind (Rec) = N_Unchecked_Type_Conversion 4255 and then Is_Entity_Name (Expression (Rec)) 4256 and then Is_Shared_Passive (Entity (Expression (Rec))) 4257 then 4258 Add_Shared_Var_Lock_Procs (N); 4259 end if; 4260 end Build_Protected_Subprogram_Call; 4261 4262 --------------------------------------------- 4263 -- Build_Protected_Subprogram_Call_Cleanup -- 4264 --------------------------------------------- 4265 4266 procedure Build_Protected_Subprogram_Call_Cleanup 4267 (Op_Spec : Node_Id; 4268 Conc_Typ : Node_Id; 4269 Loc : Source_Ptr; 4270 Stmts : List_Id) 4271 is 4272 Nam : Node_Id; 4273 4274 begin 4275 -- If the associated protected object has entries, a protected 4276 -- procedure has to service entry queues. In this case generate: 4277 4278 -- Service_Entries (_object._object'Access); 4279 4280 if Nkind (Op_Spec) = N_Procedure_Specification 4281 and then Has_Entries (Conc_Typ) 4282 then 4283 case Corresponding_Runtime_Package (Conc_Typ) is 4284 when System_Tasking_Protected_Objects_Entries => 4285 Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc); 4286 4287 when System_Tasking_Protected_Objects_Single_Entry => 4288 Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc); 4289 4290 when others => 4291 raise Program_Error; 4292 end case; 4293 4294 Append_To (Stmts, 4295 Make_Procedure_Call_Statement (Loc, 4296 Name => Nam, 4297 Parameter_Associations => New_List ( 4298 Make_Attribute_Reference (Loc, 4299 Prefix => 4300 Make_Selected_Component (Loc, 4301 Prefix => Make_Identifier (Loc, Name_uObject), 4302 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4303 Attribute_Name => Name_Unchecked_Access)))); 4304 4305 else 4306 -- Generate: 4307 -- Unlock (_object._object'Access); 4308 4309 case Corresponding_Runtime_Package (Conc_Typ) is 4310 when System_Tasking_Protected_Objects_Entries => 4311 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc); 4312 4313 when System_Tasking_Protected_Objects_Single_Entry => 4314 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc); 4315 4316 when System_Tasking_Protected_Objects => 4317 Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc); 4318 4319 when others => 4320 raise Program_Error; 4321 end case; 4322 4323 Append_To (Stmts, 4324 Make_Procedure_Call_Statement (Loc, 4325 Name => Nam, 4326 Parameter_Associations => New_List ( 4327 Make_Attribute_Reference (Loc, 4328 Prefix => 4329 Make_Selected_Component (Loc, 4330 Prefix => Make_Identifier (Loc, Name_uObject), 4331 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4332 Attribute_Name => Name_Unchecked_Access)))); 4333 end if; 4334 4335 -- Generate: 4336 -- Abort_Undefer; 4337 4338 if Abort_Allowed then 4339 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 4340 end if; 4341 end Build_Protected_Subprogram_Call_Cleanup; 4342 4343 ------------------------- 4344 -- Build_Selected_Name -- 4345 ------------------------- 4346 4347 function Build_Selected_Name 4348 (Prefix : Entity_Id; 4349 Selector : Entity_Id; 4350 Append_Char : Character := ' ') return Name_Id 4351 is 4352 Select_Buffer : String (1 .. Hostparm.Max_Name_Length); 4353 Select_Len : Natural; 4354 4355 begin 4356 Get_Name_String (Chars (Selector)); 4357 Select_Len := Name_Len; 4358 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len); 4359 Get_Name_String (Chars (Prefix)); 4360 4361 -- If scope is anonymous type, discard suffix to recover name of 4362 -- single protected object. Otherwise use protected type name. 4363 4364 if Name_Buffer (Name_Len) = 'T' then 4365 Name_Len := Name_Len - 1; 4366 end if; 4367 4368 Add_Str_To_Name_Buffer ("__"); 4369 for J in 1 .. Select_Len loop 4370 Add_Char_To_Name_Buffer (Select_Buffer (J)); 4371 end loop; 4372 4373 -- Now add the Append_Char if specified. The encoding to follow 4374 -- depends on the type of entity. If Append_Char is either 'N' or 'P', 4375 -- then the entity is associated to a protected type subprogram. 4376 -- Otherwise, it is a protected type entry. For each case, the 4377 -- encoding to follow for the suffix is documented in exp_dbug.ads. 4378 4379 -- It would be better to encapsulate this as a routine in Exp_Dbug ??? 4380 4381 if Append_Char /= ' ' then 4382 if Append_Char = 'P' or Append_Char = 'N' then 4383 Add_Char_To_Name_Buffer (Append_Char); 4384 return Name_Find; 4385 else 4386 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char)); 4387 return New_External_Name (Name_Find, ' ', -1); 4388 end if; 4389 else 4390 return Name_Find; 4391 end if; 4392 end Build_Selected_Name; 4393 4394 ----------------------------- 4395 -- Build_Simple_Entry_Call -- 4396 ----------------------------- 4397 4398 -- A task entry call is converted to a call to Call_Simple 4399 4400 -- declare 4401 -- P : parms := (parm, parm, parm); 4402 -- begin 4403 -- Call_Simple (acceptor-task, entry-index, P'Address); 4404 -- parm := P.param; 4405 -- parm := P.param; 4406 -- ... 4407 -- end; 4408 4409 -- Here Pnn is an aggregate of the type constructed for the entry to hold 4410 -- the parameters, and the constructed aggregate value contains either the 4411 -- parameters or, in the case of non-elementary types, references to these 4412 -- parameters. Then the address of this aggregate is passed to the runtime 4413 -- routine, along with the task id value and the task entry index value. 4414 -- Pnn is only required if parameters are present. 4415 4416 -- The assignments after the call are present only in the case of in-out 4417 -- or out parameters for elementary types, and are used to assign back the 4418 -- resulting values of such parameters. 4419 4420 -- Note: the reason that we insert a block here is that in the context 4421 -- of selects, conditional entry calls etc. the entry call statement 4422 -- appears on its own, not as an element of a list. 4423 4424 -- A protected entry call is converted to a Protected_Entry_Call: 4425 4426 -- declare 4427 -- P : E1_Params := (param, param, param); 4428 -- Pnn : Boolean; 4429 -- Bnn : Communications_Block; 4430 4431 -- declare 4432 -- P : E1_Params := (param, param, param); 4433 -- Bnn : Communications_Block; 4434 4435 -- begin 4436 -- Protected_Entry_Call ( 4437 -- Object => po._object'Access, 4438 -- E => <entry index>; 4439 -- Uninterpreted_Data => P'Address; 4440 -- Mode => Simple_Call; 4441 -- Block => Bnn); 4442 -- parm := P.param; 4443 -- parm := P.param; 4444 -- ... 4445 -- end; 4446 4447 procedure Build_Simple_Entry_Call 4448 (N : Node_Id; 4449 Concval : Node_Id; 4450 Ename : Node_Id; 4451 Index : Node_Id) 4452 is 4453 begin 4454 Expand_Call (N); 4455 4456 -- If call has been inlined, nothing left to do 4457 4458 if Nkind (N) = N_Block_Statement then 4459 return; 4460 end if; 4461 4462 -- Convert entry call to Call_Simple call 4463 4464 declare 4465 Loc : constant Source_Ptr := Sloc (N); 4466 Parms : constant List_Id := Parameter_Associations (N); 4467 Stats : constant List_Id := New_List; 4468 Actual : Node_Id; 4469 Call : Node_Id; 4470 Comm_Name : Entity_Id; 4471 Conctyp : Node_Id; 4472 Decls : List_Id; 4473 Ent : Entity_Id; 4474 Ent_Acc : Entity_Id; 4475 Formal : Node_Id; 4476 Iface_Tag : Entity_Id; 4477 Iface_Typ : Entity_Id; 4478 N_Node : Node_Id; 4479 N_Var : Node_Id; 4480 P : Entity_Id; 4481 Parm1 : Node_Id; 4482 Parm2 : Node_Id; 4483 Parm3 : Node_Id; 4484 Pdecl : Node_Id; 4485 Plist : List_Id; 4486 X : Entity_Id; 4487 Xdecl : Node_Id; 4488 4489 begin 4490 -- Simple entry and entry family cases merge here 4491 4492 Ent := Entity (Ename); 4493 Ent_Acc := Entry_Parameters_Type (Ent); 4494 Conctyp := Etype (Concval); 4495 4496 -- If prefix is an access type, dereference to obtain the task type 4497 4498 if Is_Access_Type (Conctyp) then 4499 Conctyp := Designated_Type (Conctyp); 4500 end if; 4501 4502 -- Special case for protected subprogram calls 4503 4504 if Is_Protected_Type (Conctyp) 4505 and then Is_Subprogram (Entity (Ename)) 4506 then 4507 if not Is_Eliminated (Entity (Ename)) then 4508 Build_Protected_Subprogram_Call 4509 (N, Ename, Convert_Concurrent (Concval, Conctyp)); 4510 Analyze (N); 4511 end if; 4512 4513 return; 4514 end if; 4515 4516 -- First parameter is the Task_Id value from the task value or the 4517 -- Object from the protected object value, obtained by selecting 4518 -- the _Task_Id or _Object from the result of doing an unchecked 4519 -- conversion to convert the value to the corresponding record type. 4520 4521 if Nkind (Concval) = N_Function_Call 4522 and then Is_Task_Type (Conctyp) 4523 and then Ada_Version >= Ada_2005 4524 then 4525 declare 4526 ExpR : constant Node_Id := Relocate_Node (Concval); 4527 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR); 4528 Decl : Node_Id; 4529 4530 begin 4531 Decl := 4532 Make_Object_Declaration (Loc, 4533 Defining_Identifier => Obj, 4534 Object_Definition => New_Occurrence_Of (Conctyp, Loc), 4535 Expression => ExpR); 4536 Set_Etype (Obj, Conctyp); 4537 Decls := New_List (Decl); 4538 Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); 4539 end; 4540 4541 else 4542 Decls := New_List; 4543 end if; 4544 4545 Parm1 := Concurrent_Ref (Concval); 4546 4547 -- Second parameter is the entry index, computed by the routine 4548 -- provided for this purpose. The value of this expression is 4549 -- assigned to an intermediate variable to assure that any entry 4550 -- family index expressions are evaluated before the entry 4551 -- parameters. 4552 4553 if not Is_Protected_Type (Conctyp) 4554 or else 4555 Corresponding_Runtime_Package (Conctyp) = 4556 System_Tasking_Protected_Objects_Entries 4557 then 4558 X := Make_Defining_Identifier (Loc, Name_uX); 4559 4560 Xdecl := 4561 Make_Object_Declaration (Loc, 4562 Defining_Identifier => X, 4563 Object_Definition => 4564 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), 4565 Expression => Actual_Index_Expression ( 4566 Loc, Entity (Ename), Index, Concval)); 4567 4568 Append_To (Decls, Xdecl); 4569 Parm2 := New_Occurrence_Of (X, Loc); 4570 4571 else 4572 Xdecl := Empty; 4573 Parm2 := Empty; 4574 end if; 4575 4576 -- The third parameter is the packaged parameters. If there are 4577 -- none, then it is just the null address, since nothing is passed. 4578 4579 if No (Parms) then 4580 Parm3 := New_Occurrence_Of (RTE (RE_Null_Address), Loc); 4581 P := Empty; 4582 4583 -- Case of parameters present, where third argument is the address 4584 -- of a packaged record containing the required parameter values. 4585 4586 else 4587 -- First build a list of parameter values, which are references to 4588 -- objects of the parameter types. 4589 4590 Plist := New_List; 4591 4592 Actual := First_Actual (N); 4593 Formal := First_Formal (Ent); 4594 while Present (Actual) loop 4595 4596 -- If it is a by-copy type, copy it to a new variable. The 4597 -- packaged record has a field that points to this variable. 4598 4599 if Is_By_Copy_Type (Etype (Actual)) then 4600 N_Node := 4601 Make_Object_Declaration (Loc, 4602 Defining_Identifier => Make_Temporary (Loc, 'J'), 4603 Aliased_Present => True, 4604 Object_Definition => 4605 New_Occurrence_Of (Etype (Formal), Loc)); 4606 4607 -- Mark the object as not needing initialization since the 4608 -- initialization is performed separately, avoiding errors 4609 -- on cases such as formals of null-excluding access types. 4610 4611 Set_No_Initialization (N_Node); 4612 4613 -- We must make a separate assignment statement for the 4614 -- case of limited types. We cannot assign it unless the 4615 -- Assignment_OK flag is set first. An out formal of an 4616 -- access type or whose type has a Default_Value must also 4617 -- be initialized from the actual (see RM 6.4.1 (13-13.1)), 4618 -- but no constraint, predicate, or null-exclusion check is 4619 -- applied before the call. 4620 4621 if Ekind (Formal) /= E_Out_Parameter 4622 or else Is_Access_Type (Etype (Formal)) 4623 or else 4624 (Is_Scalar_Type (Etype (Formal)) 4625 and then 4626 Present (Default_Aspect_Value (Etype (Formal)))) 4627 then 4628 N_Var := 4629 New_Occurrence_Of (Defining_Identifier (N_Node), Loc); 4630 Set_Assignment_OK (N_Var); 4631 Append_To (Stats, 4632 Make_Assignment_Statement (Loc, 4633 Name => N_Var, 4634 Expression => Relocate_Node (Actual))); 4635 4636 -- Mark the object as internal, so we don't later reset 4637 -- No_Initialization flag in Default_Initialize_Object, 4638 -- which would lead to needless default initialization. 4639 -- We don't set this outside the if statement, because 4640 -- out scalar parameters without Default_Value do require 4641 -- default initialization if Initialize_Scalars applies. 4642 4643 Set_Is_Internal (Defining_Identifier (N_Node)); 4644 4645 -- If actual is an out parameter of a null-excluding 4646 -- access type, there is access check on entry, so set 4647 -- Suppress_Assignment_Checks on the generated statement 4648 -- that assigns the actual to the parameter block. 4649 4650 Set_Suppress_Assignment_Checks (Last (Stats)); 4651 end if; 4652 4653 Append (N_Node, Decls); 4654 4655 Append_To (Plist, 4656 Make_Attribute_Reference (Loc, 4657 Attribute_Name => Name_Unchecked_Access, 4658 Prefix => 4659 New_Occurrence_Of 4660 (Defining_Identifier (N_Node), Loc))); 4661 4662 else 4663 -- Interface class-wide formal 4664 4665 if Ada_Version >= Ada_2005 4666 and then Ekind (Etype (Formal)) = E_Class_Wide_Type 4667 and then Is_Interface (Etype (Formal)) 4668 then 4669 Iface_Typ := Etype (Etype (Formal)); 4670 4671 -- Generate: 4672 -- formal_iface_type! (actual.iface_tag)'reference 4673 4674 Iface_Tag := 4675 Find_Interface_Tag (Etype (Actual), Iface_Typ); 4676 pragma Assert (Present (Iface_Tag)); 4677 4678 Append_To (Plist, 4679 Make_Reference (Loc, 4680 Unchecked_Convert_To (Iface_Typ, 4681 Make_Selected_Component (Loc, 4682 Prefix => 4683 Relocate_Node (Actual), 4684 Selector_Name => 4685 New_Occurrence_Of (Iface_Tag, Loc))))); 4686 else 4687 -- Generate: 4688 -- actual'reference 4689 4690 Append_To (Plist, 4691 Make_Reference (Loc, Relocate_Node (Actual))); 4692 end if; 4693 end if; 4694 4695 Next_Actual (Actual); 4696 Next_Formal_With_Extras (Formal); 4697 end loop; 4698 4699 -- Now build the declaration of parameters initialized with the 4700 -- aggregate containing this constructed parameter list. 4701 4702 P := Make_Defining_Identifier (Loc, Name_uP); 4703 4704 Pdecl := 4705 Make_Object_Declaration (Loc, 4706 Defining_Identifier => P, 4707 Object_Definition => 4708 New_Occurrence_Of (Designated_Type (Ent_Acc), Loc), 4709 Expression => 4710 Make_Aggregate (Loc, Expressions => Plist)); 4711 4712 Parm3 := 4713 Make_Attribute_Reference (Loc, 4714 Prefix => New_Occurrence_Of (P, Loc), 4715 Attribute_Name => Name_Address); 4716 4717 Append (Pdecl, Decls); 4718 end if; 4719 4720 -- Now we can create the call, case of protected type 4721 4722 if Is_Protected_Type (Conctyp) then 4723 case Corresponding_Runtime_Package (Conctyp) is 4724 when System_Tasking_Protected_Objects_Entries => 4725 4726 -- Change the type of the index declaration 4727 4728 Set_Object_Definition (Xdecl, 4729 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)); 4730 4731 -- Some additional declarations for protected entry calls 4732 4733 if No (Decls) then 4734 Decls := New_List; 4735 end if; 4736 4737 -- Bnn : Communications_Block; 4738 4739 Comm_Name := Make_Temporary (Loc, 'B'); 4740 4741 Append_To (Decls, 4742 Make_Object_Declaration (Loc, 4743 Defining_Identifier => Comm_Name, 4744 Object_Definition => 4745 New_Occurrence_Of 4746 (RTE (RE_Communication_Block), Loc))); 4747 4748 -- Some additional statements for protected entry calls 4749 4750 -- Protected_Entry_Call 4751 -- (Object => po._object'Access, 4752 -- E => <entry index>; 4753 -- Uninterpreted_Data => P'Address; 4754 -- Mode => Simple_Call; 4755 -- Block => Bnn); 4756 4757 Call := 4758 Make_Procedure_Call_Statement (Loc, 4759 Name => 4760 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), 4761 4762 Parameter_Associations => New_List ( 4763 Make_Attribute_Reference (Loc, 4764 Attribute_Name => Name_Unchecked_Access, 4765 Prefix => Parm1), 4766 Parm2, 4767 Parm3, 4768 New_Occurrence_Of (RTE (RE_Simple_Call), Loc), 4769 New_Occurrence_Of (Comm_Name, Loc))); 4770 4771 when System_Tasking_Protected_Objects_Single_Entry => 4772 4773 -- Protected_Single_Entry_Call 4774 -- (Object => po._object'Access, 4775 -- Uninterpreted_Data => P'Address); 4776 4777 Call := 4778 Make_Procedure_Call_Statement (Loc, 4779 Name => 4780 New_Occurrence_Of 4781 (RTE (RE_Protected_Single_Entry_Call), Loc), 4782 4783 Parameter_Associations => New_List ( 4784 Make_Attribute_Reference (Loc, 4785 Attribute_Name => Name_Unchecked_Access, 4786 Prefix => Parm1), 4787 Parm3)); 4788 4789 when others => 4790 raise Program_Error; 4791 end case; 4792 4793 -- Case of task type 4794 4795 else 4796 Call := 4797 Make_Procedure_Call_Statement (Loc, 4798 Name => 4799 New_Occurrence_Of (RTE (RE_Call_Simple), Loc), 4800 Parameter_Associations => New_List (Parm1, Parm2, Parm3)); 4801 4802 end if; 4803 4804 Append_To (Stats, Call); 4805 4806 -- If there are out or in/out parameters by copy add assignment 4807 -- statements for the result values. 4808 4809 if Present (Parms) then 4810 Actual := First_Actual (N); 4811 Formal := First_Formal (Ent); 4812 4813 Set_Assignment_OK (Actual); 4814 while Present (Actual) loop 4815 if Is_By_Copy_Type (Etype (Actual)) 4816 and then Ekind (Formal) /= E_In_Parameter 4817 then 4818 N_Node := 4819 Make_Assignment_Statement (Loc, 4820 Name => New_Copy (Actual), 4821 Expression => 4822 Make_Explicit_Dereference (Loc, 4823 Make_Selected_Component (Loc, 4824 Prefix => New_Occurrence_Of (P, Loc), 4825 Selector_Name => 4826 Make_Identifier (Loc, Chars (Formal))))); 4827 4828 -- In all cases (including limited private types) we want 4829 -- the assignment to be valid. 4830 4831 Set_Assignment_OK (Name (N_Node)); 4832 4833 -- If the call is the triggering alternative in an 4834 -- asynchronous select, or the entry_call alternative of a 4835 -- conditional entry call, the assignments for in-out 4836 -- parameters are incorporated into the statement list that 4837 -- follows, so that there are executed only if the entry 4838 -- call succeeds. 4839 4840 if (Nkind (Parent (N)) = N_Triggering_Alternative 4841 and then N = Triggering_Statement (Parent (N))) 4842 or else 4843 (Nkind (Parent (N)) = N_Entry_Call_Alternative 4844 and then N = Entry_Call_Statement (Parent (N))) 4845 then 4846 if No (Statements (Parent (N))) then 4847 Set_Statements (Parent (N), New_List); 4848 end if; 4849 4850 Prepend (N_Node, Statements (Parent (N))); 4851 4852 else 4853 Insert_After (Call, N_Node); 4854 end if; 4855 end if; 4856 4857 Next_Actual (Actual); 4858 Next_Formal_With_Extras (Formal); 4859 end loop; 4860 end if; 4861 4862 -- Finally, create block and analyze it 4863 4864 Rewrite (N, 4865 Make_Block_Statement (Loc, 4866 Declarations => Decls, 4867 Handled_Statement_Sequence => 4868 Make_Handled_Sequence_Of_Statements (Loc, 4869 Statements => Stats))); 4870 4871 Analyze (N); 4872 end; 4873 end Build_Simple_Entry_Call; 4874 4875 -------------------------------- 4876 -- Build_Task_Activation_Call -- 4877 -------------------------------- 4878 4879 procedure Build_Task_Activation_Call (N : Node_Id) is 4880 function Activation_Call_Loc return Source_Ptr; 4881 -- Find a suitable source location for the activation call 4882 4883 ------------------------- 4884 -- Activation_Call_Loc -- 4885 ------------------------- 4886 4887 function Activation_Call_Loc return Source_Ptr is 4888 begin 4889 -- The activation call must carry the location of the "end" keyword 4890 -- when the context is a package declaration. 4891 4892 if Nkind (N) = N_Package_Declaration then 4893 return End_Keyword_Location (N); 4894 4895 -- Otherwise the activation call must carry the location of the 4896 -- "begin" keyword. 4897 4898 else 4899 return Begin_Keyword_Location (N); 4900 end if; 4901 end Activation_Call_Loc; 4902 4903 -- Local variables 4904 4905 Chain : Entity_Id; 4906 Call : Node_Id; 4907 Loc : Source_Ptr; 4908 Name : Node_Id; 4909 Owner : Node_Id; 4910 Stmt : Node_Id; 4911 4912 -- Start of processing for Build_Task_Activation_Call 4913 4914 begin 4915 -- For sequential elaboration policy, all the tasks will be activated at 4916 -- the end of the elaboration. 4917 4918 if Partition_Elaboration_Policy = 'S' then 4919 return; 4920 4921 -- Do not create an activation call for a package spec if the package 4922 -- has a completing body. The activation call will be inserted after 4923 -- the "begin" of the body. 4924 4925 elsif Nkind (N) = N_Package_Declaration 4926 and then Present (Corresponding_Body (N)) 4927 then 4928 return; 4929 end if; 4930 4931 -- Obtain the activation chain entity. Block statements, entry bodies, 4932 -- subprogram bodies, and task bodies keep the entity in their nodes. 4933 -- Package bodies on the other hand store it in the declaration of the 4934 -- corresponding package spec. 4935 4936 Owner := N; 4937 4938 if Nkind (Owner) = N_Package_Body then 4939 Owner := Unit_Declaration_Node (Corresponding_Spec (Owner)); 4940 end if; 4941 4942 Chain := Activation_Chain_Entity (Owner); 4943 4944 -- Nothing to do when there are no tasks to activate. This is indicated 4945 -- by a missing activation chain entity. 4946 4947 if No (Chain) then 4948 return; 4949 end if; 4950 4951 -- The location of the activation call must be as close as possible to 4952 -- the intended semantic location of the activation because the ABE 4953 -- mechanism relies heavily on accurate locations. 4954 4955 Loc := Activation_Call_Loc; 4956 4957 if Restricted_Profile then 4958 Name := New_Occurrence_Of (RTE (RE_Activate_Restricted_Tasks), Loc); 4959 else 4960 Name := New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc); 4961 end if; 4962 4963 Call := 4964 Make_Procedure_Call_Statement (Loc, 4965 Name => Name, 4966 Parameter_Associations => 4967 New_List (Make_Attribute_Reference (Loc, 4968 Prefix => New_Occurrence_Of (Chain, Loc), 4969 Attribute_Name => Name_Unchecked_Access))); 4970 4971 if Nkind (N) = N_Package_Declaration then 4972 if Present (Private_Declarations (Specification (N))) then 4973 Append (Call, Private_Declarations (Specification (N))); 4974 else 4975 Append (Call, Visible_Declarations (Specification (N))); 4976 end if; 4977 4978 else 4979 -- The call goes at the start of the statement sequence after the 4980 -- start of exception range label if one is present. 4981 4982 if Present (Handled_Statement_Sequence (N)) then 4983 Stmt := First (Statements (Handled_Statement_Sequence (N))); 4984 4985 -- A special case, skip exception range label if one is present 4986 -- (from front end zcx processing). 4987 4988 if Nkind (Stmt) = N_Label and then Exception_Junk (Stmt) then 4989 Next (Stmt); 4990 end if; 4991 4992 -- Another special case, if the first statement is a block from 4993 -- optimization of a local raise to a goto, then the call goes 4994 -- inside this block. 4995 4996 if Nkind (Stmt) = N_Block_Statement 4997 and then Exception_Junk (Stmt) 4998 then 4999 Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); 5000 end if; 5001 5002 -- Insertion point is after any exception label pushes, since we 5003 -- want it covered by any local handlers. 5004 5005 while Nkind (Stmt) in N_Push_xxx_Label loop 5006 Next (Stmt); 5007 end loop; 5008 5009 -- Now we have the proper insertion point 5010 5011 Insert_Before (Stmt, Call); 5012 5013 else 5014 Set_Handled_Statement_Sequence (N, 5015 Make_Handled_Sequence_Of_Statements (Loc, 5016 Statements => New_List (Call))); 5017 end if; 5018 end if; 5019 5020 Analyze (Call); 5021 5022 if Legacy_Elaboration_Checks then 5023 Check_Task_Activation (N); 5024 end if; 5025 end Build_Task_Activation_Call; 5026 5027 ------------------------------- 5028 -- Build_Task_Allocate_Block -- 5029 ------------------------------- 5030 5031 procedure Build_Task_Allocate_Block 5032 (Actions : List_Id; 5033 N : Node_Id; 5034 Args : List_Id) 5035 is 5036 T : constant Entity_Id := Entity (Expression (N)); 5037 Init : constant Entity_Id := Base_Init_Proc (T); 5038 Loc : constant Source_Ptr := Sloc (N); 5039 Chain : constant Entity_Id := 5040 Make_Defining_Identifier (Loc, Name_uChain); 5041 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 5042 Block : Node_Id; 5043 5044 begin 5045 Block := 5046 Make_Block_Statement (Loc, 5047 Identifier => New_Occurrence_Of (Blkent, Loc), 5048 Declarations => New_List ( 5049 5050 -- _Chain : Activation_Chain; 5051 5052 Make_Object_Declaration (Loc, 5053 Defining_Identifier => Chain, 5054 Aliased_Present => True, 5055 Object_Definition => 5056 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5057 5058 Handled_Statement_Sequence => 5059 Make_Handled_Sequence_Of_Statements (Loc, 5060 5061 Statements => New_List ( 5062 5063 -- Init (Args); 5064 5065 Make_Procedure_Call_Statement (Loc, 5066 Name => New_Occurrence_Of (Init, Loc), 5067 Parameter_Associations => Args), 5068 5069 -- Activate_Tasks (_Chain); 5070 5071 Make_Procedure_Call_Statement (Loc, 5072 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 5073 Parameter_Associations => New_List ( 5074 Make_Attribute_Reference (Loc, 5075 Prefix => New_Occurrence_Of (Chain, Loc), 5076 Attribute_Name => Name_Unchecked_Access))))), 5077 5078 Has_Created_Identifier => True, 5079 Is_Task_Allocation_Block => True); 5080 5081 Append_To (Actions, 5082 Make_Implicit_Label_Declaration (Loc, 5083 Defining_Identifier => Blkent, 5084 Label_Construct => Block)); 5085 5086 Append_To (Actions, Block); 5087 5088 Set_Activation_Chain_Entity (Block, Chain); 5089 end Build_Task_Allocate_Block; 5090 5091 ----------------------------------------------- 5092 -- Build_Task_Allocate_Block_With_Init_Stmts -- 5093 ----------------------------------------------- 5094 5095 procedure Build_Task_Allocate_Block_With_Init_Stmts 5096 (Actions : List_Id; 5097 N : Node_Id; 5098 Init_Stmts : List_Id) 5099 is 5100 Loc : constant Source_Ptr := Sloc (N); 5101 Chain : constant Entity_Id := 5102 Make_Defining_Identifier (Loc, Name_uChain); 5103 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 5104 Block : Node_Id; 5105 5106 begin 5107 Append_To (Init_Stmts, 5108 Make_Procedure_Call_Statement (Loc, 5109 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 5110 Parameter_Associations => New_List ( 5111 Make_Attribute_Reference (Loc, 5112 Prefix => New_Occurrence_Of (Chain, Loc), 5113 Attribute_Name => Name_Unchecked_Access)))); 5114 5115 Block := 5116 Make_Block_Statement (Loc, 5117 Identifier => New_Occurrence_Of (Blkent, Loc), 5118 Declarations => New_List ( 5119 5120 -- _Chain : Activation_Chain; 5121 5122 Make_Object_Declaration (Loc, 5123 Defining_Identifier => Chain, 5124 Aliased_Present => True, 5125 Object_Definition => 5126 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5127 5128 Handled_Statement_Sequence => 5129 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts), 5130 5131 Has_Created_Identifier => True, 5132 Is_Task_Allocation_Block => True); 5133 5134 Append_To (Actions, 5135 Make_Implicit_Label_Declaration (Loc, 5136 Defining_Identifier => Blkent, 5137 Label_Construct => Block)); 5138 5139 Append_To (Actions, Block); 5140 5141 Set_Activation_Chain_Entity (Block, Chain); 5142 end Build_Task_Allocate_Block_With_Init_Stmts; 5143 5144 ----------------------------------- 5145 -- Build_Task_Proc_Specification -- 5146 ----------------------------------- 5147 5148 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is 5149 Loc : constant Source_Ptr := Sloc (T); 5150 Spec_Id : Entity_Id; 5151 5152 begin 5153 -- Case of explicit task type, suffix TB 5154 5155 if Comes_From_Source (T) then 5156 Spec_Id := 5157 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB")); 5158 5159 -- Case of anonymous task type, suffix B 5160 5161 else 5162 Spec_Id := 5163 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B')); 5164 end if; 5165 5166 Set_Is_Internal (Spec_Id); 5167 5168 -- Associate the procedure with the task, if this is the declaration 5169 -- (and not the body) of the procedure. 5170 5171 if No (Task_Body_Procedure (T)) then 5172 Set_Task_Body_Procedure (T, Spec_Id); 5173 end if; 5174 5175 return 5176 Make_Procedure_Specification (Loc, 5177 Defining_Unit_Name => Spec_Id, 5178 Parameter_Specifications => New_List ( 5179 Make_Parameter_Specification (Loc, 5180 Defining_Identifier => 5181 Make_Defining_Identifier (Loc, Name_uTask), 5182 Parameter_Type => 5183 Make_Access_Definition (Loc, 5184 Subtype_Mark => 5185 New_Occurrence_Of (Corresponding_Record_Type (T), Loc))))); 5186 end Build_Task_Proc_Specification; 5187 5188 --------------------------------------- 5189 -- Build_Unprotected_Subprogram_Body -- 5190 --------------------------------------- 5191 5192 function Build_Unprotected_Subprogram_Body 5193 (N : Node_Id; 5194 Pid : Node_Id) return Node_Id 5195 is 5196 Decls : constant List_Id := Declarations (N); 5197 5198 begin 5199 -- Add renamings for the Protection object, discriminals, privals, and 5200 -- the entry index constant for use by debugger. 5201 5202 Debug_Private_Data_Declarations (Decls); 5203 5204 -- Make an unprotected version of the subprogram for use within the same 5205 -- object, with a new name and an additional parameter representing the 5206 -- object. 5207 5208 return 5209 Make_Subprogram_Body (Sloc (N), 5210 Specification => 5211 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), 5212 Declarations => Decls, 5213 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 5214 end Build_Unprotected_Subprogram_Body; 5215 5216 ---------------------------- 5217 -- Collect_Entry_Families -- 5218 ---------------------------- 5219 5220 procedure Collect_Entry_Families 5221 (Loc : Source_Ptr; 5222 Cdecls : List_Id; 5223 Current_Node : in out Node_Id; 5224 Conctyp : Entity_Id) 5225 is 5226 Efam : Entity_Id; 5227 Efam_Decl : Node_Id; 5228 Efam_Type : Entity_Id; 5229 5230 begin 5231 Efam := First_Entity (Conctyp); 5232 while Present (Efam) loop 5233 if Ekind (Efam) = E_Entry_Family then 5234 Efam_Type := Make_Temporary (Loc, 'F'); 5235 5236 declare 5237 Bas : Entity_Id := 5238 Base_Type 5239 (Etype (Discrete_Subtype_Definition (Parent (Efam)))); 5240 5241 Bas_Decl : Node_Id := Empty; 5242 Lo, Hi : Node_Id; 5243 5244 begin 5245 Get_Index_Bounds 5246 (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi); 5247 5248 if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then 5249 Bas := Make_Temporary (Loc, 'B'); 5250 5251 Bas_Decl := 5252 Make_Subtype_Declaration (Loc, 5253 Defining_Identifier => Bas, 5254 Subtype_Indication => 5255 Make_Subtype_Indication (Loc, 5256 Subtype_Mark => 5257 New_Occurrence_Of (Standard_Integer, Loc), 5258 Constraint => 5259 Make_Range_Constraint (Loc, 5260 Range_Expression => Make_Range (Loc, 5261 Make_Integer_Literal 5262 (Loc, -Entry_Family_Bound), 5263 Make_Integer_Literal 5264 (Loc, Entry_Family_Bound - 1))))); 5265 5266 Insert_After (Current_Node, Bas_Decl); 5267 Current_Node := Bas_Decl; 5268 Analyze (Bas_Decl); 5269 end if; 5270 5271 Efam_Decl := 5272 Make_Full_Type_Declaration (Loc, 5273 Defining_Identifier => Efam_Type, 5274 Type_Definition => 5275 Make_Unconstrained_Array_Definition (Loc, 5276 Subtype_Marks => 5277 (New_List (New_Occurrence_Of (Bas, Loc))), 5278 5279 Component_Definition => 5280 Make_Component_Definition (Loc, 5281 Aliased_Present => False, 5282 Subtype_Indication => 5283 New_Occurrence_Of (Standard_Character, Loc)))); 5284 end; 5285 5286 Insert_After (Current_Node, Efam_Decl); 5287 Current_Node := Efam_Decl; 5288 Analyze (Efam_Decl); 5289 5290 Append_To (Cdecls, 5291 Make_Component_Declaration (Loc, 5292 Defining_Identifier => 5293 Make_Defining_Identifier (Loc, Chars (Efam)), 5294 5295 Component_Definition => 5296 Make_Component_Definition (Loc, 5297 Aliased_Present => False, 5298 Subtype_Indication => 5299 Make_Subtype_Indication (Loc, 5300 Subtype_Mark => 5301 New_Occurrence_Of (Efam_Type, Loc), 5302 5303 Constraint => 5304 Make_Index_Or_Discriminant_Constraint (Loc, 5305 Constraints => New_List ( 5306 New_Occurrence_Of 5307 (Etype (Discrete_Subtype_Definition 5308 (Parent (Efam))), Loc))))))); 5309 5310 end if; 5311 5312 Next_Entity (Efam); 5313 end loop; 5314 end Collect_Entry_Families; 5315 5316 ----------------------- 5317 -- Concurrent_Object -- 5318 ----------------------- 5319 5320 function Concurrent_Object 5321 (Spec_Id : Entity_Id; 5322 Conc_Typ : Entity_Id) return Entity_Id 5323 is 5324 begin 5325 -- Parameter _O or _object 5326 5327 if Is_Protected_Type (Conc_Typ) then 5328 return First_Formal (Protected_Body_Subprogram (Spec_Id)); 5329 5330 -- Parameter _task 5331 5332 else 5333 pragma Assert (Is_Task_Type (Conc_Typ)); 5334 return First_Formal (Task_Body_Procedure (Conc_Typ)); 5335 end if; 5336 end Concurrent_Object; 5337 5338 ---------------------- 5339 -- Copy_Result_Type -- 5340 ---------------------- 5341 5342 function Copy_Result_Type (Res : Node_Id) return Node_Id is 5343 New_Res : constant Node_Id := New_Copy_Tree (Res); 5344 Par_Spec : Node_Id; 5345 Formal : Entity_Id; 5346 5347 begin 5348 -- If the result type is an access_to_subprogram, we must create new 5349 -- entities for its spec. 5350 5351 if Nkind (New_Res) = N_Access_Definition 5352 and then Present (Access_To_Subprogram_Definition (New_Res)) 5353 then 5354 -- Provide new entities for the formals 5355 5356 Par_Spec := First (Parameter_Specifications 5357 (Access_To_Subprogram_Definition (New_Res))); 5358 while Present (Par_Spec) loop 5359 Formal := Defining_Identifier (Par_Spec); 5360 Set_Defining_Identifier (Par_Spec, 5361 Make_Defining_Identifier (Sloc (Formal), Chars (Formal))); 5362 Next (Par_Spec); 5363 end loop; 5364 end if; 5365 5366 return New_Res; 5367 end Copy_Result_Type; 5368 5369 -------------------- 5370 -- Concurrent_Ref -- 5371 -------------------- 5372 5373 -- The expression returned for a reference to a concurrent object has the 5374 -- form: 5375 5376 -- taskV!(name)._Task_Id 5377 5378 -- for a task, and 5379 5380 -- objectV!(name)._Object 5381 5382 -- for a protected object. For the case of an access to a concurrent 5383 -- object, there is an extra explicit dereference: 5384 5385 -- taskV!(name.all)._Task_Id 5386 -- objectV!(name.all)._Object 5387 5388 -- here taskV and objectV are the types for the associated records, which 5389 -- contain the required _Task_Id and _Object fields for tasks and protected 5390 -- objects, respectively. 5391 5392 -- For the case of a task type name, the expression is 5393 5394 -- Self; 5395 5396 -- i.e. a call to the Self function which returns precisely this Task_Id 5397 5398 -- For the case of a protected type name, the expression is 5399 5400 -- objectR 5401 5402 -- which is a renaming of the _object field of the current object 5403 -- record, passed into protected operations as a parameter. 5404 5405 function Concurrent_Ref (N : Node_Id) return Node_Id is 5406 Loc : constant Source_Ptr := Sloc (N); 5407 Ntyp : constant Entity_Id := Etype (N); 5408 Dtyp : Entity_Id; 5409 Sel : Name_Id; 5410 5411 function Is_Current_Task (T : Entity_Id) return Boolean; 5412 -- Check whether the reference is to the immediately enclosing task 5413 -- type, or to an outer one (rare but legal). 5414 5415 --------------------- 5416 -- Is_Current_Task -- 5417 --------------------- 5418 5419 function Is_Current_Task (T : Entity_Id) return Boolean is 5420 Scop : Entity_Id; 5421 5422 begin 5423 Scop := Current_Scope; 5424 while Present (Scop) and then Scop /= Standard_Standard loop 5425 if Scop = T then 5426 return True; 5427 5428 elsif Is_Task_Type (Scop) then 5429 return False; 5430 5431 -- If this is a procedure nested within the task type, we must 5432 -- assume that it can be called from an inner task, and therefore 5433 -- cannot treat it as a local reference. 5434 5435 elsif Is_Overloadable (Scop) and then In_Open_Scopes (T) then 5436 return False; 5437 5438 else 5439 Scop := Scope (Scop); 5440 end if; 5441 end loop; 5442 5443 -- We know that we are within the task body, so should have found it 5444 -- in scope. 5445 5446 raise Program_Error; 5447 end Is_Current_Task; 5448 5449 -- Start of processing for Concurrent_Ref 5450 5451 begin 5452 if Is_Access_Type (Ntyp) then 5453 Dtyp := Designated_Type (Ntyp); 5454 5455 if Is_Protected_Type (Dtyp) then 5456 Sel := Name_uObject; 5457 else 5458 Sel := Name_uTask_Id; 5459 end if; 5460 5461 return 5462 Make_Selected_Component (Loc, 5463 Prefix => 5464 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp), 5465 Make_Explicit_Dereference (Loc, N)), 5466 Selector_Name => Make_Identifier (Loc, Sel)); 5467 5468 elsif Is_Entity_Name (N) and then Is_Concurrent_Type (Entity (N)) then 5469 if Is_Task_Type (Entity (N)) then 5470 5471 if Is_Current_Task (Entity (N)) then 5472 return 5473 Make_Function_Call (Loc, 5474 Name => New_Occurrence_Of (RTE (RE_Self), Loc)); 5475 5476 else 5477 declare 5478 Decl : Node_Id; 5479 T_Self : constant Entity_Id := Make_Temporary (Loc, 'T'); 5480 T_Body : constant Node_Id := 5481 Parent (Corresponding_Body (Parent (Entity (N)))); 5482 5483 begin 5484 Decl := 5485 Make_Object_Declaration (Loc, 5486 Defining_Identifier => T_Self, 5487 Object_Definition => 5488 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 5489 Expression => 5490 Make_Function_Call (Loc, 5491 Name => New_Occurrence_Of (RTE (RE_Self), Loc))); 5492 Prepend (Decl, Declarations (T_Body)); 5493 Analyze (Decl); 5494 Set_Scope (T_Self, Entity (N)); 5495 return New_Occurrence_Of (T_Self, Loc); 5496 end; 5497 end if; 5498 5499 else 5500 pragma Assert (Is_Protected_Type (Entity (N))); 5501 5502 return 5503 New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc); 5504 end if; 5505 5506 else 5507 if Is_Protected_Type (Ntyp) then 5508 Sel := Name_uObject; 5509 elsif Is_Task_Type (Ntyp) then 5510 Sel := Name_uTask_Id; 5511 else 5512 raise Program_Error; 5513 end if; 5514 5515 return 5516 Make_Selected_Component (Loc, 5517 Prefix => 5518 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp), 5519 New_Copy_Tree (N)), 5520 Selector_Name => Make_Identifier (Loc, Sel)); 5521 end if; 5522 end Concurrent_Ref; 5523 5524 ------------------------ 5525 -- Convert_Concurrent -- 5526 ------------------------ 5527 5528 function Convert_Concurrent 5529 (N : Node_Id; 5530 Typ : Entity_Id) return Node_Id 5531 is 5532 begin 5533 if not Is_Concurrent_Type (Typ) then 5534 return N; 5535 else 5536 return 5537 Unchecked_Convert_To 5538 (Corresponding_Record_Type (Typ), New_Copy_Tree (N)); 5539 end if; 5540 end Convert_Concurrent; 5541 5542 ------------------------------------- 5543 -- Create_Secondary_Stack_For_Task -- 5544 ------------------------------------- 5545 5546 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean is 5547 begin 5548 return 5549 (Restriction_Active (No_Implicit_Heap_Allocations) 5550 or else Restriction_Active (No_Implicit_Task_Allocations)) 5551 and then not Restriction_Active (No_Secondary_Stack) 5552 and then Has_Rep_Pragma 5553 (T, Name_Secondary_Stack_Size, Check_Parents => False); 5554 end Create_Secondary_Stack_For_Task; 5555 5556 ------------------------------------- 5557 -- Debug_Private_Data_Declarations -- 5558 ------------------------------------- 5559 5560 procedure Debug_Private_Data_Declarations (Decls : List_Id) is 5561 Debug_Nod : Node_Id; 5562 Decl : Node_Id; 5563 5564 begin 5565 Decl := First (Decls); 5566 while Present (Decl) and then not Comes_From_Source (Decl) loop 5567 5568 -- Declaration for concurrent entity _object and its access type, 5569 -- along with the entry index subtype: 5570 -- type prot_typVP is access prot_typV; 5571 -- _object : prot_typVP := prot_typV (_O); 5572 -- subtype Jnn is <Type of Index> range Low .. High; 5573 5574 if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then 5575 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5576 5577 -- Declaration for the Protection object, discriminals, privals, and 5578 -- entry index constant: 5579 -- conc_typR : protection_typ renames _object._object; 5580 -- discr_nameD : discr_typ renames _object.discr_name; 5581 -- discr_nameD : discr_typ renames _task.discr_name; 5582 -- prival_name : comp_typ renames _object.comp_name; 5583 -- J : constant Jnn := 5584 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First)); 5585 5586 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 5587 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5588 Debug_Nod := Debug_Renaming_Declaration (Decl); 5589 5590 if Present (Debug_Nod) then 5591 Insert_After (Decl, Debug_Nod); 5592 end if; 5593 end if; 5594 5595 Next (Decl); 5596 end loop; 5597 end Debug_Private_Data_Declarations; 5598 5599 ------------------------------ 5600 -- Ensure_Statement_Present -- 5601 ------------------------------ 5602 5603 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is 5604 Stmt : Node_Id; 5605 5606 begin 5607 if Opt.Suppress_Control_Flow_Optimizations 5608 and then Is_Empty_List (Statements (Alt)) 5609 then 5610 Stmt := Make_Null_Statement (Loc); 5611 5612 -- Mark NULL statement as coming from source so that it is not 5613 -- eliminated by GIGI. 5614 5615 -- Another covert channel. If this is a requirement, it must be 5616 -- documented in sinfo/einfo ??? 5617 5618 Set_Comes_From_Source (Stmt, True); 5619 5620 Set_Statements (Alt, New_List (Stmt)); 5621 end if; 5622 end Ensure_Statement_Present; 5623 5624 ---------------------------- 5625 -- Entry_Index_Expression -- 5626 ---------------------------- 5627 5628 function Entry_Index_Expression 5629 (Sloc : Source_Ptr; 5630 Ent : Entity_Id; 5631 Index : Node_Id; 5632 Ttyp : Entity_Id) return Node_Id 5633 is 5634 Expr : Node_Id; 5635 Num : Node_Id; 5636 Lo : Node_Id; 5637 Hi : Node_Id; 5638 Prev : Entity_Id; 5639 S : Node_Id; 5640 5641 begin 5642 -- The queues of entries and entry families appear in textual order in 5643 -- the associated record. The entry index is computed as the sum of the 5644 -- number of queues for all entries that precede the designated one, to 5645 -- which is added the index expression, if this expression denotes a 5646 -- member of a family. 5647 5648 -- The following is a place holder for the count of simple entries 5649 5650 Num := Make_Integer_Literal (Sloc, 1); 5651 5652 -- We construct an expression which is a series of addition operations. 5653 -- The first operand is the number of single entries that precede this 5654 -- one, the second operand is the index value relative to the start of 5655 -- the referenced family, and the remaining operands are the lengths of 5656 -- the entry families that precede this entry, i.e. the constructed 5657 -- expression is: 5658 5659 -- number_simple_entries + 5660 -- (s'pos (index-value) - s'pos (family'first)) + 1 + 5661 -- family'length + ... 5662 5663 -- where index-value is the given index value, and s is the index 5664 -- subtype (we have to use pos because the subtype might be an 5665 -- enumeration type preventing direct subtraction). Note that the task 5666 -- entry array is one-indexed. 5667 5668 -- The upper bound of the entry family may be a discriminant, so we 5669 -- retrieve the lower bound explicitly to compute offset, rather than 5670 -- using the index subtype which may mention a discriminant. 5671 5672 if Present (Index) then 5673 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); 5674 5675 Expr := 5676 Make_Op_Add (Sloc, 5677 Left_Opnd => Num, 5678 Right_Opnd => 5679 Family_Offset 5680 (Sloc, 5681 Make_Attribute_Reference (Sloc, 5682 Attribute_Name => Name_Pos, 5683 Prefix => New_Occurrence_Of (Base_Type (S), Sloc), 5684 Expressions => New_List (Relocate_Node (Index))), 5685 Type_Low_Bound (S), 5686 Ttyp, 5687 False)); 5688 else 5689 Expr := Num; 5690 end if; 5691 5692 -- Now add lengths of preceding entries and entry families 5693 5694 Prev := First_Entity (Ttyp); 5695 while Chars (Prev) /= Chars (Ent) 5696 or else (Ekind (Prev) /= Ekind (Ent)) 5697 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 5698 loop 5699 if Ekind (Prev) = E_Entry then 5700 Set_Intval (Num, Intval (Num) + 1); 5701 5702 elsif Ekind (Prev) = E_Entry_Family then 5703 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 5704 Lo := Type_Low_Bound (S); 5705 Hi := Type_High_Bound (S); 5706 5707 Expr := 5708 Make_Op_Add (Sloc, 5709 Left_Opnd => Expr, 5710 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False)); 5711 5712 -- Other components are anonymous types to be ignored 5713 5714 else 5715 null; 5716 end if; 5717 5718 Next_Entity (Prev); 5719 end loop; 5720 5721 return Expr; 5722 end Entry_Index_Expression; 5723 5724 --------------------------- 5725 -- Establish_Task_Master -- 5726 --------------------------- 5727 5728 procedure Establish_Task_Master (N : Node_Id) is 5729 Call : Node_Id; 5730 5731 begin 5732 if Restriction_Active (No_Task_Hierarchy) = False then 5733 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); 5734 5735 -- The block may have no declarations (and nevertheless be a task 5736 -- master) if it contains a call that may return an object that 5737 -- contains tasks. 5738 5739 if No (Declarations (N)) then 5740 Set_Declarations (N, New_List (Call)); 5741 else 5742 Prepend_To (Declarations (N), Call); 5743 end if; 5744 5745 Analyze (Call); 5746 end if; 5747 end Establish_Task_Master; 5748 5749 -------------------------------- 5750 -- Expand_Accept_Declarations -- 5751 -------------------------------- 5752 5753 -- Part of the expansion of an accept statement involves the creation of 5754 -- a declaration that can be referenced from the statement sequence of 5755 -- the accept: 5756 5757 -- Ann : Address; 5758 5759 -- This declaration is inserted immediately before the accept statement 5760 -- and it is important that it be inserted before the statements of the 5761 -- statement sequence are analyzed. Thus it would be too late to create 5762 -- this declaration in the Expand_N_Accept_Statement routine, which is 5763 -- why there is a separate procedure to be called directly from Sem_Ch9. 5764 5765 -- Ann is used to hold the address of the record containing the parameters 5766 -- (see Expand_N_Entry_Call for more details on how this record is built). 5767 -- References to the parameters do an unchecked conversion of this address 5768 -- to a pointer to the required record type, and then access the field that 5769 -- holds the value of the required parameter. The entity for the address 5770 -- variable is held as the top stack element (i.e. the last element) of the 5771 -- Accept_Address stack in the corresponding entry entity, and this element 5772 -- must be set in place before the statements are processed. 5773 5774 -- The above description applies to the case of a stand alone accept 5775 -- statement, i.e. one not appearing as part of a select alternative. 5776 5777 -- For the case of an accept that appears as part of a select alternative 5778 -- of a selective accept, we must still create the declaration right away, 5779 -- since Ann is needed immediately, but there is an important difference: 5780 5781 -- The declaration is inserted before the selective accept, not before 5782 -- the accept statement (which is not part of a list anyway, and so would 5783 -- not accommodate inserted declarations) 5784 5785 -- We only need one address variable for the entire selective accept. So 5786 -- the Ann declaration is created only for the first accept alternative, 5787 -- and subsequent accept alternatives reference the same Ann variable. 5788 5789 -- We can distinguish the two cases by seeing whether the accept statement 5790 -- is part of a list. If not, then it must be in an accept alternative. 5791 5792 -- To expand the requeue statement, a label is provided at the end of the 5793 -- accept statement or alternative of which it is a part, so that the 5794 -- statement can be skipped after the requeue is complete. This label is 5795 -- created here rather than during the expansion of the accept statement, 5796 -- because it will be needed by any requeue statements within the accept, 5797 -- which are expanded before the accept. 5798 5799 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is 5800 Loc : constant Source_Ptr := Sloc (N); 5801 Stats : constant Node_Id := Handled_Statement_Sequence (N); 5802 Ann : Entity_Id := Empty; 5803 Adecl : Node_Id; 5804 Lab : Node_Id; 5805 Ldecl : Node_Id; 5806 Ldecl2 : Node_Id; 5807 5808 begin 5809 if Expander_Active then 5810 5811 -- If we have no handled statement sequence, we may need to build 5812 -- a dummy sequence consisting of a null statement. This can be 5813 -- skipped if the trivial accept optimization is permitted. 5814 5815 if not Trivial_Accept_OK 5816 and then (No (Stats) or else Null_Statements (Statements (Stats))) 5817 then 5818 Set_Handled_Statement_Sequence (N, 5819 Make_Handled_Sequence_Of_Statements (Loc, 5820 Statements => New_List (Make_Null_Statement (Loc)))); 5821 end if; 5822 5823 -- Create and declare two labels to be placed at the end of the 5824 -- accept statement. The first label is used to allow requeues to 5825 -- skip the remainder of entry processing. The second label is used 5826 -- to skip the remainder of entry processing if the rendezvous 5827 -- completes in the middle of the accept body. 5828 5829 if Present (Handled_Statement_Sequence (N)) then 5830 declare 5831 Ent : Entity_Id; 5832 5833 begin 5834 Ent := Make_Temporary (Loc, 'L'); 5835 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 5836 Ldecl := 5837 Make_Implicit_Label_Declaration (Loc, 5838 Defining_Identifier => Ent, 5839 Label_Construct => Lab); 5840 Append (Lab, Statements (Handled_Statement_Sequence (N))); 5841 5842 Ent := Make_Temporary (Loc, 'L'); 5843 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 5844 Ldecl2 := 5845 Make_Implicit_Label_Declaration (Loc, 5846 Defining_Identifier => Ent, 5847 Label_Construct => Lab); 5848 Append (Lab, Statements (Handled_Statement_Sequence (N))); 5849 end; 5850 5851 else 5852 Ldecl := Empty; 5853 Ldecl2 := Empty; 5854 end if; 5855 5856 -- Case of stand alone accept statement 5857 5858 if Is_List_Member (N) then 5859 5860 if Present (Handled_Statement_Sequence (N)) then 5861 Ann := Make_Temporary (Loc, 'A'); 5862 5863 Adecl := 5864 Make_Object_Declaration (Loc, 5865 Defining_Identifier => Ann, 5866 Object_Definition => 5867 New_Occurrence_Of (RTE (RE_Address), Loc)); 5868 5869 Insert_Before_And_Analyze (N, Adecl); 5870 Insert_Before_And_Analyze (N, Ldecl); 5871 Insert_Before_And_Analyze (N, Ldecl2); 5872 end if; 5873 5874 -- Case of accept statement which is in an accept alternative 5875 5876 else 5877 declare 5878 Acc_Alt : constant Node_Id := Parent (N); 5879 Sel_Acc : constant Node_Id := Parent (Acc_Alt); 5880 Alt : Node_Id; 5881 5882 begin 5883 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative); 5884 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept); 5885 5886 -- ??? Consider a single label for select statements 5887 5888 if Present (Handled_Statement_Sequence (N)) then 5889 Prepend (Ldecl2, 5890 Statements (Handled_Statement_Sequence (N))); 5891 Analyze (Ldecl2); 5892 5893 Prepend (Ldecl, 5894 Statements (Handled_Statement_Sequence (N))); 5895 Analyze (Ldecl); 5896 end if; 5897 5898 -- Find first accept alternative of the selective accept. A 5899 -- valid selective accept must have at least one accept in it. 5900 5901 Alt := First (Select_Alternatives (Sel_Acc)); 5902 5903 while Nkind (Alt) /= N_Accept_Alternative loop 5904 Next (Alt); 5905 end loop; 5906 5907 -- If this is the first accept statement, then we have to 5908 -- create the Ann variable, as for the stand alone case, except 5909 -- that it is inserted before the selective accept. Similarly, 5910 -- a label for requeue expansion must be declared. 5911 5912 if N = Accept_Statement (Alt) then 5913 Ann := Make_Temporary (Loc, 'A'); 5914 Adecl := 5915 Make_Object_Declaration (Loc, 5916 Defining_Identifier => Ann, 5917 Object_Definition => 5918 New_Occurrence_Of (RTE (RE_Address), Loc)); 5919 5920 Insert_Before_And_Analyze (Sel_Acc, Adecl); 5921 5922 -- If this is not the first accept statement, then find the Ann 5923 -- variable allocated by the first accept and use it. 5924 5925 else 5926 Ann := 5927 Node (Last_Elmt (Accept_Address 5928 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))))); 5929 end if; 5930 end; 5931 end if; 5932 5933 -- Merge here with Ann either created or referenced, and Adecl 5934 -- pointing to the corresponding declaration. Remaining processing 5935 -- is the same for the two cases. 5936 5937 if Present (Ann) then 5938 Append_Elmt (Ann, Accept_Address (Ent)); 5939 Set_Debug_Info_Needed (Ann); 5940 end if; 5941 5942 -- Create renaming declarations for the entry formals. Each reference 5943 -- to a formal becomes a dereference of a component of the parameter 5944 -- block, whose address is held in Ann. These declarations are 5945 -- eventually inserted into the accept block, and analyzed there so 5946 -- that they have the proper scope for gdb and do not conflict with 5947 -- other declarations. 5948 5949 if Present (Parameter_Specifications (N)) 5950 and then Present (Handled_Statement_Sequence (N)) 5951 then 5952 declare 5953 Comp : Entity_Id; 5954 Decl : Node_Id; 5955 Formal : Entity_Id; 5956 New_F : Entity_Id; 5957 Renamed_Formal : Node_Id; 5958 5959 begin 5960 Push_Scope (Ent); 5961 Formal := First_Formal (Ent); 5962 5963 while Present (Formal) loop 5964 Comp := Entry_Component (Formal); 5965 New_F := Make_Defining_Identifier (Loc, Chars (Formal)); 5966 5967 Set_Etype (New_F, Etype (Formal)); 5968 Set_Scope (New_F, Ent); 5969 5970 -- Now we set debug info needed on New_F even though it does 5971 -- not come from source, so that the debugger will get the 5972 -- right information for these generated names. 5973 5974 Set_Debug_Info_Needed (New_F); 5975 5976 if Ekind (Formal) = E_In_Parameter then 5977 Set_Ekind (New_F, E_Constant); 5978 else 5979 Set_Ekind (New_F, E_Variable); 5980 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 5981 end if; 5982 5983 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 5984 5985 Renamed_Formal := 5986 Make_Selected_Component (Loc, 5987 Prefix => 5988 Unchecked_Convert_To ( 5989 Entry_Parameters_Type (Ent), 5990 New_Occurrence_Of (Ann, Loc)), 5991 Selector_Name => 5992 New_Occurrence_Of (Comp, Loc)); 5993 5994 Decl := 5995 Build_Renamed_Formal_Declaration 5996 (New_F, Formal, Comp, Renamed_Formal); 5997 5998 if No (Declarations (N)) then 5999 Set_Declarations (N, New_List); 6000 end if; 6001 6002 Append (Decl, Declarations (N)); 6003 Set_Renamed_Object (Formal, New_F); 6004 Next_Formal (Formal); 6005 end loop; 6006 6007 End_Scope; 6008 end; 6009 end if; 6010 end if; 6011 end Expand_Accept_Declarations; 6012 6013 --------------------------------------------- 6014 -- Expand_Access_Protected_Subprogram_Type -- 6015 --------------------------------------------- 6016 6017 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is 6018 Loc : constant Source_Ptr := Sloc (N); 6019 T : constant Entity_Id := Defining_Identifier (N); 6020 D_T : constant Entity_Id := Designated_Type (T); 6021 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D'); 6022 E_T : constant Entity_Id := Make_Temporary (Loc, 'E'); 6023 P_List : constant List_Id := 6024 Build_Protected_Spec (N, RTE (RE_Address), D_T, False); 6025 6026 Comps : List_Id; 6027 Decl1 : Node_Id; 6028 Decl2 : Node_Id; 6029 Def1 : Node_Id; 6030 6031 begin 6032 -- Create access to subprogram with full signature 6033 6034 if Etype (D_T) /= Standard_Void_Type then 6035 Def1 := 6036 Make_Access_Function_Definition (Loc, 6037 Parameter_Specifications => P_List, 6038 Result_Definition => 6039 Copy_Result_Type (Result_Definition (Type_Definition (N)))); 6040 6041 else 6042 Def1 := 6043 Make_Access_Procedure_Definition (Loc, 6044 Parameter_Specifications => P_List); 6045 end if; 6046 6047 Decl1 := 6048 Make_Full_Type_Declaration (Loc, 6049 Defining_Identifier => D_T2, 6050 Type_Definition => Def1); 6051 6052 -- Declare the new types before the original one since the latter will 6053 -- refer to them through the Equivalent_Type slot. 6054 6055 Insert_Before_And_Analyze (N, Decl1); 6056 6057 -- Associate the access to subprogram with its original access to 6058 -- protected subprogram type. Needed by the backend to know that this 6059 -- type corresponds with an access to protected subprogram type. 6060 6061 Set_Original_Access_Type (D_T2, T); 6062 6063 -- Create Equivalent_Type, a record with two components for an access to 6064 -- object and an access to subprogram. 6065 6066 Comps := New_List ( 6067 Make_Component_Declaration (Loc, 6068 Defining_Identifier => Make_Temporary (Loc, 'P'), 6069 Component_Definition => 6070 Make_Component_Definition (Loc, 6071 Aliased_Present => False, 6072 Subtype_Indication => 6073 New_Occurrence_Of (RTE (RE_Address), Loc))), 6074 6075 Make_Component_Declaration (Loc, 6076 Defining_Identifier => Make_Temporary (Loc, 'S'), 6077 Component_Definition => 6078 Make_Component_Definition (Loc, 6079 Aliased_Present => False, 6080 Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); 6081 6082 Decl2 := 6083 Make_Full_Type_Declaration (Loc, 6084 Defining_Identifier => E_T, 6085 Type_Definition => 6086 Make_Record_Definition (Loc, 6087 Component_List => 6088 Make_Component_List (Loc, Component_Items => Comps))); 6089 6090 Insert_Before_And_Analyze (N, Decl2); 6091 Set_Equivalent_Type (T, E_T); 6092 end Expand_Access_Protected_Subprogram_Type; 6093 6094 -------------------------- 6095 -- Expand_Entry_Barrier -- 6096 -------------------------- 6097 6098 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is 6099 Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N)); 6100 Prot : constant Entity_Id := Scope (Ent); 6101 Spec_Decl : constant Node_Id := Parent (Prot); 6102 6103 Func_Id : Entity_Id := Empty; 6104 -- The entity of the barrier function 6105 6106 function Is_Global_Entity (N : Node_Id) return Traverse_Result; 6107 -- Check whether entity in Barrier is external to protected type. 6108 -- If so, barrier may not be properly synchronized. 6109 6110 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result; 6111 -- Check whether N follows the Pure_Barriers restriction. Return OK if 6112 -- so. 6113 6114 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean; 6115 -- Check whether entity name N denotes a component of the protected 6116 -- object. This is used to check the Simple_Barrier restriction. 6117 6118 ---------------------- 6119 -- Is_Global_Entity -- 6120 ---------------------- 6121 6122 function Is_Global_Entity (N : Node_Id) return Traverse_Result is 6123 E : Entity_Id; 6124 S : Entity_Id; 6125 6126 begin 6127 if Is_Entity_Name (N) and then Present (Entity (N)) then 6128 E := Entity (N); 6129 S := Scope (E); 6130 6131 if Ekind (E) = E_Variable then 6132 6133 -- If the variable is local to the barrier function generated 6134 -- during expansion, it is ok. If expansion is not performed, 6135 -- then Func is Empty so this test cannot succeed. 6136 6137 if Scope (E) = Func_Id then 6138 null; 6139 6140 -- A protected call from a barrier to another object is ok 6141 6142 elsif Ekind (Etype (E)) = E_Protected_Type then 6143 null; 6144 6145 -- If the variable is within the package body we consider 6146 -- this safe. This is a common (if dubious) idiom. 6147 6148 elsif S = Scope (Prot) 6149 and then Ekind_In (S, E_Package, E_Generic_Package) 6150 and then Nkind (Parent (E)) = N_Object_Declaration 6151 and then Nkind (Parent (Parent (E))) = N_Package_Body 6152 then 6153 null; 6154 6155 else 6156 Error_Msg_N ("potentially unsynchronized barrier??", N); 6157 Error_Msg_N ("\& should be private component of type??", N); 6158 end if; 6159 end if; 6160 end if; 6161 6162 return OK; 6163 end Is_Global_Entity; 6164 6165 procedure Check_Unprotected_Barrier is 6166 new Traverse_Proc (Is_Global_Entity); 6167 6168 ---------------------------- 6169 -- Is_Simple_Barrier_Name -- 6170 ---------------------------- 6171 6172 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is 6173 Renamed : Node_Id; 6174 6175 begin 6176 -- Check if the name is a component of the protected object. If 6177 -- the expander is active, the component has been transformed into a 6178 -- renaming of _object.all.component. Original_Node is needed in case 6179 -- validity checking is enabled, in which case the simple object 6180 -- reference will have been rewritten. 6181 6182 if Expander_Active then 6183 6184 -- The expanded name may have been constant folded in which case 6185 -- the original node is not necessarily an entity name (e.g. an 6186 -- indexed component). 6187 6188 if not Is_Entity_Name (Original_Node (N)) then 6189 return False; 6190 end if; 6191 6192 Renamed := Renamed_Object (Entity (Original_Node (N))); 6193 6194 return 6195 Present (Renamed) 6196 and then Nkind (Renamed) = N_Selected_Component 6197 and then Chars (Prefix (Prefix (Renamed))) = Name_uObject; 6198 else 6199 return Is_Protected_Component (Entity (N)); 6200 end if; 6201 end Is_Simple_Barrier_Name; 6202 6203 --------------------- 6204 -- Is_Pure_Barrier -- 6205 --------------------- 6206 6207 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is 6208 begin 6209 case Nkind (N) is 6210 when N_Expanded_Name 6211 | N_Identifier 6212 => 6213 if No (Entity (N)) then 6214 return Abandon; 6215 6216 elsif Is_Universal_Numeric_Type (Entity (N)) then 6217 return OK; 6218 end if; 6219 6220 case Ekind (Entity (N)) is 6221 when E_Constant 6222 | E_Discriminant 6223 | E_Enumeration_Literal 6224 | E_Named_Integer 6225 | E_Named_Real 6226 => 6227 return OK; 6228 6229 when E_Component => 6230 return OK; 6231 6232 when E_Variable => 6233 if Is_Simple_Barrier_Name (N) then 6234 return OK; 6235 end if; 6236 6237 when E_Function => 6238 6239 -- The count attribute has been transformed into run-time 6240 -- calls. 6241 6242 if Is_RTE (Entity (N), RE_Protected_Count) 6243 or else Is_RTE (Entity (N), RE_Protected_Count_Entry) 6244 then 6245 return OK; 6246 end if; 6247 6248 when others => 6249 null; 6250 end case; 6251 6252 when N_Function_Call => 6253 6254 -- Function call checks are carried out as part of the analysis 6255 -- of the function call name. 6256 6257 return OK; 6258 6259 when N_Character_Literal 6260 | N_Integer_Literal 6261 | N_Real_Literal 6262 => 6263 return OK; 6264 6265 when N_Op_Boolean 6266 | N_Op_Not 6267 => 6268 if Ekind (Entity (N)) = E_Operator then 6269 return OK; 6270 end if; 6271 6272 when N_Short_Circuit => 6273 return OK; 6274 6275 when N_Indexed_Component 6276 | N_Selected_Component 6277 => 6278 if not Is_Access_Type (Etype (Prefix (N))) then 6279 return OK; 6280 end if; 6281 6282 when N_Type_Conversion => 6283 6284 -- Conversions to Universal_Integer will not raise constraint 6285 -- errors. 6286 6287 if Cannot_Raise_Constraint_Error (N) 6288 or else Etype (N) = Universal_Integer 6289 then 6290 return OK; 6291 end if; 6292 6293 when N_Unchecked_Type_Conversion => 6294 return OK; 6295 6296 when others => 6297 null; 6298 end case; 6299 6300 return Abandon; 6301 end Is_Pure_Barrier; 6302 6303 function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier); 6304 6305 -- Local variables 6306 6307 Cond_Id : Entity_Id; 6308 Entry_Body : Node_Id; 6309 Func_Body : Node_Id := Empty; 6310 6311 -- Start of processing for Expand_Entry_Barrier 6312 6313 begin 6314 if No_Run_Time_Mode then 6315 Error_Msg_CRT ("entry barrier", N); 6316 return; 6317 end if; 6318 6319 -- The body of the entry barrier must be analyzed in the context of the 6320 -- protected object, but its scope is external to it, just as any other 6321 -- unprotected version of a protected operation. The specification has 6322 -- been produced when the protected type declaration was elaborated. We 6323 -- build the body, insert it in the enclosing scope, but analyze it in 6324 -- the current context. A more uniform approach would be to treat the 6325 -- barrier just as a protected function, and discard the protected 6326 -- version of it because it is never called. 6327 6328 if Expander_Active then 6329 Func_Body := Build_Barrier_Function (N, Ent, Prot); 6330 Func_Id := Barrier_Function (Ent); 6331 Set_Corresponding_Spec (Func_Body, Func_Id); 6332 6333 Entry_Body := Parent (Corresponding_Body (Spec_Decl)); 6334 6335 if Nkind (Parent (Entry_Body)) = N_Subunit then 6336 Entry_Body := Corresponding_Stub (Parent (Entry_Body)); 6337 end if; 6338 6339 Insert_Before_And_Analyze (Entry_Body, Func_Body); 6340 6341 Set_Discriminals (Spec_Decl); 6342 Set_Scope (Func_Id, Scope (Prot)); 6343 6344 else 6345 Analyze_And_Resolve (Cond, Any_Boolean); 6346 end if; 6347 6348 -- Check Pure_Barriers restriction 6349 6350 if Check_Pure_Barriers (Cond) = Abandon then 6351 Check_Restriction (Pure_Barriers, Cond); 6352 end if; 6353 6354 -- The Ravenscar profile restricts barriers to simple variables declared 6355 -- within the protected object. We also allow Boolean constants, since 6356 -- these appear in several published examples and are also allowed by 6357 -- other compilers. 6358 6359 -- Note that after analysis variables in this context will be replaced 6360 -- by the corresponding prival, that is to say a renaming of a selected 6361 -- component of the form _Object.Var. If expansion is disabled, as 6362 -- within a generic, we check that the entity appears in the current 6363 -- scope. 6364 6365 if Is_Entity_Name (Cond) then 6366 Cond_Id := Entity (Cond); 6367 6368 -- Perform a small optimization of simple barrier functions. If the 6369 -- scope of the condition's entity is not the barrier function, then 6370 -- the condition does not depend on any of the generated renamings. 6371 -- If this is the case, eliminate the renamings as they are useless. 6372 -- This optimization is not performed when the condition was folded 6373 -- and validity checks are in effect because the original condition 6374 -- may have produced at least one check that depends on the generated 6375 -- renamings. 6376 6377 if Expander_Active 6378 and then Scope (Cond_Id) /= Func_Id 6379 and then not Validity_Check_Operands 6380 then 6381 Set_Declarations (Func_Body, Empty_List); 6382 end if; 6383 6384 if Cond_Id = Standard_False or else Cond_Id = Standard_True then 6385 return; 6386 6387 elsif Is_Simple_Barrier_Name (Cond) then 6388 return; 6389 end if; 6390 end if; 6391 6392 -- It is not a boolean variable or literal, so check the restriction. 6393 -- Note that it is safe to be calling Check_Restriction from here, even 6394 -- though this is part of the expander, since Expand_Entry_Barrier is 6395 -- called from Sem_Ch9 even in -gnatc mode. 6396 6397 Check_Restriction (Simple_Barriers, Cond); 6398 6399 -- Emit warning if barrier contains global entities and is thus 6400 -- potentially unsynchronized. 6401 6402 Check_Unprotected_Barrier (Cond); 6403 end Expand_Entry_Barrier; 6404 6405 ------------------------------ 6406 -- Expand_N_Abort_Statement -- 6407 ------------------------------ 6408 6409 -- Expand abort T1, T2, .. Tn; into: 6410 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...)) 6411 6412 procedure Expand_N_Abort_Statement (N : Node_Id) is 6413 Loc : constant Source_Ptr := Sloc (N); 6414 Tlist : constant List_Id := Names (N); 6415 Count : Nat; 6416 Aggr : Node_Id; 6417 Tasknm : Node_Id; 6418 6419 begin 6420 Aggr := Make_Aggregate (Loc, Component_Associations => New_List); 6421 Count := 0; 6422 6423 Tasknm := First (Tlist); 6424 6425 while Present (Tasknm) loop 6426 Count := Count + 1; 6427 6428 -- A task interface class-wide type object is being aborted. Retrieve 6429 -- its _task_id by calling a dispatching routine. 6430 6431 if Ada_Version >= Ada_2005 6432 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type 6433 and then Is_Interface (Etype (Tasknm)) 6434 and then Is_Task_Interface (Etype (Tasknm)) 6435 then 6436 Append_To (Component_Associations (Aggr), 6437 Make_Component_Association (Loc, 6438 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6439 Expression => 6440 6441 -- Task_Id (Tasknm._disp_get_task_id) 6442 6443 Make_Unchecked_Type_Conversion (Loc, 6444 Subtype_Mark => 6445 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 6446 Expression => 6447 Make_Selected_Component (Loc, 6448 Prefix => New_Copy_Tree (Tasknm), 6449 Selector_Name => 6450 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))); 6451 6452 else 6453 Append_To (Component_Associations (Aggr), 6454 Make_Component_Association (Loc, 6455 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6456 Expression => Concurrent_Ref (Tasknm))); 6457 end if; 6458 6459 Next (Tasknm); 6460 end loop; 6461 6462 Rewrite (N, 6463 Make_Procedure_Call_Statement (Loc, 6464 Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc), 6465 Parameter_Associations => New_List ( 6466 Make_Qualified_Expression (Loc, 6467 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_List), Loc), 6468 Expression => Aggr)))); 6469 6470 Analyze (N); 6471 end Expand_N_Abort_Statement; 6472 6473 ------------------------------- 6474 -- Expand_N_Accept_Statement -- 6475 ------------------------------- 6476 6477 -- This procedure handles expansion of accept statements that stand alone, 6478 -- i.e. they are not part of an accept alternative. The expansion of 6479 -- accept statement in accept alternatives is handled by the routines 6480 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The 6481 -- following description applies only to stand alone accept statements. 6482 6483 -- If there is no handled statement sequence, or only null statements, then 6484 -- this is called a trivial accept, and the expansion is: 6485 6486 -- Accept_Trivial (entry-index) 6487 6488 -- If there is a handled statement sequence, then the expansion is: 6489 6490 -- Ann : Address; 6491 -- {Lnn : Label} 6492 6493 -- begin 6494 -- begin 6495 -- Accept_Call (entry-index, Ann); 6496 -- Renaming_Declarations for formals 6497 -- <statement sequence from N_Accept_Statement node> 6498 -- Complete_Rendezvous; 6499 -- <<Lnn>> 6500 -- 6501 -- exception 6502 -- when ... => 6503 -- <exception handler from N_Accept_Statement node> 6504 -- Complete_Rendezvous; 6505 -- when ... => 6506 -- <exception handler from N_Accept_Statement node> 6507 -- Complete_Rendezvous; 6508 -- ... 6509 -- end; 6510 6511 -- exception 6512 -- when all others => 6513 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 6514 -- end; 6515 6516 -- The first three declarations were already inserted ahead of the accept 6517 -- statement by the Expand_Accept_Declarations procedure, which was called 6518 -- directly from the semantics during analysis of the accept statement, 6519 -- before analyzing its contained statements. 6520 6521 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come 6522 -- from possible expansion activity (the original source of course does 6523 -- not have any declarations associated with the accept statement, since 6524 -- an accept statement has no declarative part). In particular, if the 6525 -- expander is active, the first such declaration is the declaration of 6526 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement). 6527 6528 -- The two blocks are merged into a single block if the inner block has 6529 -- no exception handlers, but otherwise two blocks are required, since 6530 -- exceptions might be raised in the exception handlers of the inner 6531 -- block, and Exceptional_Complete_Rendezvous must be called. 6532 6533 procedure Expand_N_Accept_Statement (N : Node_Id) is 6534 Loc : constant Source_Ptr := Sloc (N); 6535 Stats : constant Node_Id := Handled_Statement_Sequence (N); 6536 Ename : constant Node_Id := Entry_Direct_Name (N); 6537 Eindx : constant Node_Id := Entry_Index (N); 6538 Eent : constant Entity_Id := Entity (Ename); 6539 Acstack : constant Elist_Id := Accept_Address (Eent); 6540 Ann : constant Entity_Id := Node (Last_Elmt (Acstack)); 6541 Ttyp : constant Entity_Id := Etype (Scope (Eent)); 6542 Blkent : Entity_Id; 6543 Call : Node_Id; 6544 Block : Node_Id; 6545 6546 begin 6547 -- If the accept statement is not part of a list, then its parent must 6548 -- be an accept alternative, and, as described above, we do not do any 6549 -- expansion for such accept statements at this level. 6550 6551 if not Is_List_Member (N) then 6552 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative); 6553 return; 6554 6555 -- Trivial accept case (no statement sequence, or null statements). 6556 -- If the accept statement has declarations, then just insert them 6557 -- before the procedure call. 6558 6559 elsif Trivial_Accept_OK 6560 and then (No (Stats) or else Null_Statements (Statements (Stats))) 6561 then 6562 -- Remove declarations for renamings, because the parameter block 6563 -- will not be assigned. 6564 6565 declare 6566 D : Node_Id; 6567 Next_D : Node_Id; 6568 6569 begin 6570 D := First (Declarations (N)); 6571 while Present (D) loop 6572 Next_D := Next (D); 6573 if Nkind (D) = N_Object_Renaming_Declaration then 6574 Remove (D); 6575 end if; 6576 6577 D := Next_D; 6578 end loop; 6579 end; 6580 6581 if Present (Declarations (N)) then 6582 Insert_Actions (N, Declarations (N)); 6583 end if; 6584 6585 Rewrite (N, 6586 Make_Procedure_Call_Statement (Loc, 6587 Name => New_Occurrence_Of (RTE (RE_Accept_Trivial), Loc), 6588 Parameter_Associations => New_List ( 6589 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp)))); 6590 6591 Analyze (N); 6592 6593 -- Discard Entry_Address that was created for it, so it will not be 6594 -- emitted if this accept statement is in the statement part of a 6595 -- delay alternative. 6596 6597 if Present (Stats) then 6598 Remove_Last_Elmt (Acstack); 6599 end if; 6600 6601 -- Case of statement sequence present 6602 6603 else 6604 -- Construct the block, using the declarations from the accept 6605 -- statement if any to initialize the declarations of the block. 6606 6607 Blkent := Make_Temporary (Loc, 'A'); 6608 Set_Ekind (Blkent, E_Block); 6609 Set_Etype (Blkent, Standard_Void_Type); 6610 Set_Scope (Blkent, Current_Scope); 6611 6612 Block := 6613 Make_Block_Statement (Loc, 6614 Identifier => New_Occurrence_Of (Blkent, Loc), 6615 Declarations => Declarations (N), 6616 Handled_Statement_Sequence => Build_Accept_Body (N)); 6617 6618 -- For the analysis of the generated declarations, the parent node 6619 -- must be properly set. 6620 6621 Set_Parent (Block, Parent (N)); 6622 6623 -- Prepend call to Accept_Call to main statement sequence If the 6624 -- accept has exception handlers, the statement sequence is wrapped 6625 -- in a block. Insert call and renaming declarations in the 6626 -- declarations of the block, so they are elaborated before the 6627 -- handlers. 6628 6629 Call := 6630 Make_Procedure_Call_Statement (Loc, 6631 Name => New_Occurrence_Of (RTE (RE_Accept_Call), Loc), 6632 Parameter_Associations => New_List ( 6633 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp), 6634 New_Occurrence_Of (Ann, Loc))); 6635 6636 if Parent (Stats) = N then 6637 Prepend (Call, Statements (Stats)); 6638 else 6639 Set_Declarations (Parent (Stats), New_List (Call)); 6640 end if; 6641 6642 Analyze (Call); 6643 6644 Push_Scope (Blkent); 6645 6646 declare 6647 D : Node_Id; 6648 Next_D : Node_Id; 6649 Typ : Entity_Id; 6650 6651 begin 6652 D := First (Declarations (N)); 6653 while Present (D) loop 6654 Next_D := Next (D); 6655 6656 if Nkind (D) = N_Object_Renaming_Declaration then 6657 6658 -- The renaming declarations for the formals were created 6659 -- during analysis of the accept statement, and attached to 6660 -- the list of declarations. Place them now in the context 6661 -- of the accept block or subprogram. 6662 6663 Remove (D); 6664 Typ := Entity (Subtype_Mark (D)); 6665 Insert_After (Call, D); 6666 Analyze (D); 6667 6668 -- If the formal is class_wide, it does not have an actual 6669 -- subtype. The analysis of the renaming declaration creates 6670 -- one, but we need to retain the class-wide nature of the 6671 -- entity. 6672 6673 if Is_Class_Wide_Type (Typ) then 6674 Set_Etype (Defining_Identifier (D), Typ); 6675 end if; 6676 6677 end if; 6678 6679 D := Next_D; 6680 end loop; 6681 end; 6682 6683 End_Scope; 6684 6685 -- Replace the accept statement by the new block 6686 6687 Rewrite (N, Block); 6688 Analyze (N); 6689 6690 -- Last step is to unstack the Accept_Address value 6691 6692 Remove_Last_Elmt (Acstack); 6693 end if; 6694 end Expand_N_Accept_Statement; 6695 6696 ---------------------------------- 6697 -- Expand_N_Asynchronous_Select -- 6698 ---------------------------------- 6699 6700 -- This procedure assumes that the trigger statement is an entry call or 6701 -- a dispatching procedure call. A delay alternative should already have 6702 -- been expanded into an entry call to the appropriate delay object Wait 6703 -- entry. 6704 6705 -- If the trigger is a task entry call, the select is implemented with 6706 -- a Task_Entry_Call: 6707 6708 -- declare 6709 -- B : Boolean; 6710 -- C : Boolean; 6711 -- P : parms := (parm, parm, parm); 6712 6713 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6714 6715 -- procedure _clean is 6716 -- begin 6717 -- ... 6718 -- Cancel_Task_Entry_Call (C); 6719 -- ... 6720 -- end _clean; 6721 6722 -- begin 6723 -- Abort_Defer; 6724 -- Task_Entry_Call 6725 -- (<acceptor-task>, -- Acceptor 6726 -- <entry-index>, -- E 6727 -- P'Address, -- Uninterpreted_Data 6728 -- Asynchronous_Call, -- Mode 6729 -- B); -- Rendezvous_Successful 6730 6731 -- begin 6732 -- begin 6733 -- Abort_Undefer; 6734 -- <abortable-part> 6735 -- at end 6736 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6737 -- end; 6738 -- exception 6739 -- when Abort_Signal => Abort_Undefer; 6740 -- end; 6741 6742 -- parm := P.param; 6743 -- parm := P.param; 6744 -- ... 6745 -- if not C then 6746 -- <triggered-statements> 6747 -- end if; 6748 -- end; 6749 6750 -- Note that Build_Simple_Entry_Call is used to expand the entry of the 6751 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure) 6752 -- as follows: 6753 6754 -- declare 6755 -- P : parms := (parm, parm, parm); 6756 -- begin 6757 -- Call_Simple (acceptor-task, entry-index, P'Address); 6758 -- parm := P.param; 6759 -- parm := P.param; 6760 -- ... 6761 -- end; 6762 6763 -- so the task at hand is to convert the latter expansion into the former 6764 6765 -- If the trigger is a protected entry call, the select is implemented 6766 -- with Protected_Entry_Call: 6767 6768 -- declare 6769 -- P : E1_Params := (param, param, param); 6770 -- Bnn : Communications_Block; 6771 6772 -- begin 6773 -- declare 6774 6775 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6776 6777 -- procedure _clean is 6778 -- begin 6779 -- ... 6780 -- if Enqueued (Bnn) then 6781 -- Cancel_Protected_Entry_Call (Bnn); 6782 -- end if; 6783 -- ... 6784 -- end _clean; 6785 6786 -- begin 6787 -- begin 6788 -- Protected_Entry_Call 6789 -- (po._object'Access, -- Object 6790 -- <entry index>, -- E 6791 -- P'Address, -- Uninterpreted_Data 6792 -- Asynchronous_Call, -- Mode 6793 -- Bnn); -- Block 6794 6795 -- if Enqueued (Bnn) then 6796 -- <abortable-part> 6797 -- end if; 6798 -- at end 6799 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6800 -- end; 6801 -- exception 6802 -- when Abort_Signal => Abort_Undefer; 6803 -- end; 6804 6805 -- if not Cancelled (Bnn) then 6806 -- <triggered-statements> 6807 -- end if; 6808 -- end; 6809 6810 -- Build_Simple_Entry_Call is used to expand the all to a simple protected 6811 -- entry call: 6812 6813 -- declare 6814 -- P : E1_Params := (param, param, param); 6815 -- Bnn : Communications_Block; 6816 6817 -- begin 6818 -- Protected_Entry_Call 6819 -- (po._object'Access, -- Object 6820 -- <entry index>, -- E 6821 -- P'Address, -- Uninterpreted_Data 6822 -- Simple_Call, -- Mode 6823 -- Bnn); -- Block 6824 -- parm := P.param; 6825 -- parm := P.param; 6826 -- ... 6827 -- end; 6828 6829 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is 6830 -- expanded into: 6831 6832 -- declare 6833 -- B : Boolean := False; 6834 -- Bnn : Communication_Block; 6835 -- C : Ada.Tags.Prim_Op_Kind; 6836 -- D : System.Storage_Elements.Dummy_Communication_Block; 6837 -- K : Ada.Tags.Tagged_Kind := 6838 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 6839 -- P : Parameters := (Param1 .. ParamN); 6840 -- S : Integer; 6841 -- U : Boolean; 6842 6843 -- begin 6844 -- if K = Ada.Tags.TK_Limited_Tagged 6845 -- or else K = Ada.Tags.TK_Tagged 6846 -- then 6847 -- <dispatching-call>; 6848 -- <triggering-statements>; 6849 6850 -- else 6851 -- S := 6852 -- Ada.Tags.Get_Offset_Index 6853 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 6854 6855 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 6856 6857 -- if C = POK_Protected_Entry then 6858 -- declare 6859 -- procedure _clean is 6860 -- begin 6861 -- if Enqueued (Bnn) then 6862 -- Cancel_Protected_Entry_Call (Bnn); 6863 -- end if; 6864 -- end _clean; 6865 6866 -- begin 6867 -- begin 6868 -- _Disp_Asynchronous_Select 6869 -- (<object>, S, P'Address, D, B); 6870 -- Bnn := Communication_Block (D); 6871 6872 -- Param1 := P.Param1; 6873 -- ... 6874 -- ParamN := P.ParamN; 6875 6876 -- if Enqueued (Bnn) then 6877 -- <abortable-statements> 6878 -- end if; 6879 -- at end 6880 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6881 -- end; 6882 -- exception 6883 -- when Abort_Signal => Abort_Undefer; 6884 -- end; 6885 6886 -- if not Cancelled (Bnn) then 6887 -- <triggering-statements> 6888 -- end if; 6889 6890 -- elsif C = POK_Task_Entry then 6891 -- declare 6892 -- procedure _clean is 6893 -- begin 6894 -- Cancel_Task_Entry_Call (U); 6895 -- end _clean; 6896 6897 -- begin 6898 -- Abort_Defer; 6899 6900 -- _Disp_Asynchronous_Select 6901 -- (<object>, S, P'Address, D, B); 6902 -- Bnn := Communication_Bloc (D); 6903 6904 -- Param1 := P.Param1; 6905 -- ... 6906 -- ParamN := P.ParamN; 6907 6908 -- begin 6909 -- begin 6910 -- Abort_Undefer; 6911 -- <abortable-statements> 6912 -- at end 6913 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6914 -- end; 6915 -- exception 6916 -- when Abort_Signal => Abort_Undefer; 6917 -- end; 6918 6919 -- if not U then 6920 -- <triggering-statements> 6921 -- end if; 6922 -- end; 6923 6924 -- else 6925 -- <dispatching-call>; 6926 -- <triggering-statements> 6927 -- end if; 6928 -- end if; 6929 -- end; 6930 6931 -- The job is to convert this to the asynchronous form 6932 6933 -- If the trigger is a delay statement, it will have been expanded into 6934 -- a call to one of the GNARL delay procedures. This routine will convert 6935 -- this into a protected entry call on a delay object and then continue 6936 -- processing as for a protected entry call trigger. This requires 6937 -- declaring a Delay_Block object and adding a pointer to this object to 6938 -- the parameter list of the delay procedure to form the parameter list of 6939 -- the entry call. This object is used by the runtime to queue the delay 6940 -- request. 6941 6942 -- For a description of the use of P and the assignments after the call, 6943 -- see Expand_N_Entry_Call_Statement. 6944 6945 procedure Expand_N_Asynchronous_Select (N : Node_Id) is 6946 Loc : constant Source_Ptr := Sloc (N); 6947 Abrt : constant Node_Id := Abortable_Part (N); 6948 Trig : constant Node_Id := Triggering_Alternative (N); 6949 6950 Abort_Block_Ent : Entity_Id; 6951 Abortable_Block : Node_Id; 6952 Actuals : List_Id; 6953 Astats : List_Id; 6954 Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A'); 6955 Blk_Typ : Entity_Id; 6956 Call : Node_Id; 6957 Call_Ent : Entity_Id; 6958 Cancel_Param : Entity_Id; 6959 Cleanup_Block : Node_Id; 6960 Cleanup_Block_Ent : Entity_Id; 6961 Cleanup_Stmts : List_Id; 6962 Conc_Typ_Stmts : List_Id; 6963 Concval : Node_Id; 6964 Dblock_Ent : Entity_Id; 6965 Decl : Node_Id; 6966 Decls : List_Id; 6967 Ecall : Node_Id; 6968 Ename : Node_Id; 6969 Enqueue_Call : Node_Id; 6970 Formals : List_Id; 6971 Hdle : List_Id; 6972 Handler_Stmt : Node_Id; 6973 Index : Node_Id; 6974 Lim_Typ_Stmts : List_Id; 6975 N_Orig : Node_Id; 6976 Obj : Entity_Id; 6977 Param : Node_Id; 6978 Params : List_Id; 6979 Pdef : Entity_Id; 6980 ProtE_Stmts : List_Id; 6981 ProtP_Stmts : List_Id; 6982 Stmt : Node_Id; 6983 Stmts : List_Id; 6984 TaskE_Stmts : List_Id; 6985 Tstats : List_Id; 6986 6987 B : Entity_Id; -- Call status flag 6988 Bnn : Entity_Id; -- Communication block 6989 C : Entity_Id; -- Call kind 6990 K : Entity_Id; -- Tagged kind 6991 P : Entity_Id; -- Parameter block 6992 S : Entity_Id; -- Primitive operation slot 6993 T : Entity_Id; -- Additional status flag 6994 6995 procedure Rewrite_Abortable_Part; 6996 -- If the trigger is a dispatching call, the expansion inserts multiple 6997 -- copies of the abortable part. This is both inefficient, and may lead 6998 -- to duplicate definitions that the back-end will reject, when the 6999 -- abortable part includes loops. This procedure rewrites the abortable 7000 -- part into a call to a generated procedure. 7001 7002 ---------------------------- 7003 -- Rewrite_Abortable_Part -- 7004 ---------------------------- 7005 7006 procedure Rewrite_Abortable_Part is 7007 Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 7008 Decl : Node_Id; 7009 7010 begin 7011 Decl := 7012 Make_Subprogram_Body (Loc, 7013 Specification => 7014 Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc), 7015 Declarations => New_List, 7016 Handled_Statement_Sequence => 7017 Make_Handled_Sequence_Of_Statements (Loc, Astats)); 7018 Insert_Before (N, Decl); 7019 Analyze (Decl); 7020 7021 -- Rewrite abortable part into a call to this procedure 7022 7023 Astats := 7024 New_List ( 7025 Make_Procedure_Call_Statement (Loc, 7026 Name => New_Occurrence_Of (Proc, Loc))); 7027 end Rewrite_Abortable_Part; 7028 7029 -- Start of processing for Expand_N_Asynchronous_Select 7030 7031 begin 7032 -- Asynchronous select is not supported on restricted runtimes. Don't 7033 -- try to expand. 7034 7035 if Restricted_Profile then 7036 return; 7037 end if; 7038 7039 Process_Statements_For_Controlled_Objects (Trig); 7040 Process_Statements_For_Controlled_Objects (Abrt); 7041 7042 Ecall := Triggering_Statement (Trig); 7043 7044 Ensure_Statement_Present (Sloc (Ecall), Trig); 7045 7046 -- Retrieve Astats and Tstats now because the finalization machinery may 7047 -- wrap them in blocks. 7048 7049 Astats := Statements (Abrt); 7050 Tstats := Statements (Trig); 7051 7052 -- The arguments in the call may require dynamic allocation, and the 7053 -- call statement may have been transformed into a block. The block 7054 -- may contain additional declarations for internal entities, and the 7055 -- original call is found by sequential search. 7056 7057 if Nkind (Ecall) = N_Block_Statement then 7058 Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); 7059 while not Nkind_In (Ecall, N_Procedure_Call_Statement, 7060 N_Entry_Call_Statement) 7061 loop 7062 Next (Ecall); 7063 end loop; 7064 end if; 7065 7066 -- This is either a dispatching call or a delay statement used as a 7067 -- trigger which was expanded into a procedure call. 7068 7069 if Nkind (Ecall) = N_Procedure_Call_Statement then 7070 if Ada_Version >= Ada_2005 7071 and then 7072 (No (Original_Node (Ecall)) 7073 or else not Nkind_In (Original_Node (Ecall), 7074 N_Delay_Relative_Statement, 7075 N_Delay_Until_Statement)) 7076 then 7077 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals); 7078 7079 Rewrite_Abortable_Part; 7080 Decls := New_List; 7081 Stmts := New_List; 7082 7083 -- Call status flag processing, generate: 7084 -- B : Boolean := False; 7085 7086 B := Build_B (Loc, Decls); 7087 7088 -- Communication block processing, generate: 7089 -- Bnn : Communication_Block; 7090 7091 Bnn := Make_Temporary (Loc, 'B'); 7092 Append_To (Decls, 7093 Make_Object_Declaration (Loc, 7094 Defining_Identifier => Bnn, 7095 Object_Definition => 7096 New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); 7097 7098 -- Call kind processing, generate: 7099 -- C : Ada.Tags.Prim_Op_Kind; 7100 7101 C := Build_C (Loc, Decls); 7102 7103 -- Tagged kind processing, generate: 7104 -- K : Ada.Tags.Tagged_Kind := 7105 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7106 7107 -- Dummy communication block, generate: 7108 -- D : Dummy_Communication_Block; 7109 7110 Append_To (Decls, 7111 Make_Object_Declaration (Loc, 7112 Defining_Identifier => 7113 Make_Defining_Identifier (Loc, Name_uD), 7114 Object_Definition => 7115 New_Occurrence_Of 7116 (RTE (RE_Dummy_Communication_Block), Loc))); 7117 7118 K := Build_K (Loc, Decls, Obj); 7119 7120 -- Parameter block processing 7121 7122 Blk_Typ := Build_Parameter_Block 7123 (Loc, Actuals, Formals, Decls); 7124 P := Parameter_Block_Pack 7125 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 7126 7127 -- Dispatch table slot processing, generate: 7128 -- S : Integer; 7129 7130 S := Build_S (Loc, Decls); 7131 7132 -- Additional status flag processing, generate: 7133 -- Tnn : Boolean; 7134 7135 T := Make_Temporary (Loc, 'T'); 7136 Append_To (Decls, 7137 Make_Object_Declaration (Loc, 7138 Defining_Identifier => T, 7139 Object_Definition => 7140 New_Occurrence_Of (Standard_Boolean, Loc))); 7141 7142 ------------------------------ 7143 -- Protected entry handling -- 7144 ------------------------------ 7145 7146 -- Generate: 7147 -- Param1 := P.Param1; 7148 -- ... 7149 -- ParamN := P.ParamN; 7150 7151 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7152 7153 -- Generate: 7154 -- Bnn := Communication_Block (D); 7155 7156 Prepend_To (Cleanup_Stmts, 7157 Make_Assignment_Statement (Loc, 7158 Name => New_Occurrence_Of (Bnn, Loc), 7159 Expression => 7160 Make_Unchecked_Type_Conversion (Loc, 7161 Subtype_Mark => 7162 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7163 Expression => Make_Identifier (Loc, Name_uD)))); 7164 7165 -- Generate: 7166 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7167 7168 Prepend_To (Cleanup_Stmts, 7169 Make_Procedure_Call_Statement (Loc, 7170 Name => 7171 New_Occurrence_Of 7172 (Find_Prim_Op 7173 (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select), 7174 Loc), 7175 Parameter_Associations => 7176 New_List ( 7177 New_Copy_Tree (Obj), -- <object> 7178 New_Occurrence_Of (S, Loc), -- S 7179 Make_Attribute_Reference (Loc, -- P'Address 7180 Prefix => New_Occurrence_Of (P, Loc), 7181 Attribute_Name => Name_Address), 7182 Make_Identifier (Loc, Name_uD), -- D 7183 New_Occurrence_Of (B, Loc)))); -- B 7184 7185 -- Generate: 7186 -- if Enqueued (Bnn) then 7187 -- <abortable-statements> 7188 -- end if; 7189 7190 Append_To (Cleanup_Stmts, 7191 Make_Implicit_If_Statement (N, 7192 Condition => 7193 Make_Function_Call (Loc, 7194 Name => 7195 New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7196 Parameter_Associations => 7197 New_List (New_Occurrence_Of (Bnn, Loc))), 7198 7199 Then_Statements => 7200 New_Copy_List_Tree (Astats))); 7201 7202 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7203 -- will then generate a _clean for the communication block Bnn. 7204 7205 -- Generate: 7206 -- declare 7207 -- procedure _clean is 7208 -- begin 7209 -- if Enqueued (Bnn) then 7210 -- Cancel_Protected_Entry_Call (Bnn); 7211 -- end if; 7212 -- end _clean; 7213 -- begin 7214 -- Cleanup_Stmts 7215 -- at end 7216 -- _clean; 7217 -- end; 7218 7219 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7220 Cleanup_Block := 7221 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn); 7222 7223 -- Wrap the cleanup block in an exception handling block 7224 7225 -- Generate: 7226 -- begin 7227 -- Cleanup_Block 7228 -- exception 7229 -- when Abort_Signal => Abort_Undefer; 7230 -- end; 7231 7232 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7233 ProtE_Stmts := 7234 New_List ( 7235 Make_Implicit_Label_Declaration (Loc, 7236 Defining_Identifier => Abort_Block_Ent), 7237 7238 Build_Abort_Block 7239 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7240 7241 -- Generate: 7242 -- if not Cancelled (Bnn) then 7243 -- <triggering-statements> 7244 -- end if; 7245 7246 Append_To (ProtE_Stmts, 7247 Make_Implicit_If_Statement (N, 7248 Condition => 7249 Make_Op_Not (Loc, 7250 Right_Opnd => 7251 Make_Function_Call (Loc, 7252 Name => 7253 New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7254 Parameter_Associations => 7255 New_List (New_Occurrence_Of (Bnn, Loc)))), 7256 7257 Then_Statements => 7258 New_Copy_List_Tree (Tstats))); 7259 7260 ------------------------- 7261 -- Task entry handling -- 7262 ------------------------- 7263 7264 -- Generate: 7265 -- Param1 := P.Param1; 7266 -- ... 7267 -- ParamN := P.ParamN; 7268 7269 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7270 7271 -- Generate: 7272 -- Bnn := Communication_Block (D); 7273 7274 Append_To (TaskE_Stmts, 7275 Make_Assignment_Statement (Loc, 7276 Name => 7277 New_Occurrence_Of (Bnn, Loc), 7278 Expression => 7279 Make_Unchecked_Type_Conversion (Loc, 7280 Subtype_Mark => 7281 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7282 Expression => Make_Identifier (Loc, Name_uD)))); 7283 7284 -- Generate: 7285 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7286 7287 Prepend_To (TaskE_Stmts, 7288 Make_Procedure_Call_Statement (Loc, 7289 Name => 7290 New_Occurrence_Of ( 7291 Find_Prim_Op (Etype (Etype (Obj)), 7292 Name_uDisp_Asynchronous_Select), 7293 Loc), 7294 7295 Parameter_Associations => New_List ( 7296 New_Copy_Tree (Obj), -- <object> 7297 New_Occurrence_Of (S, Loc), -- S 7298 Make_Attribute_Reference (Loc, -- P'Address 7299 Prefix => New_Occurrence_Of (P, Loc), 7300 Attribute_Name => Name_Address), 7301 Make_Identifier (Loc, Name_uD), -- D 7302 New_Occurrence_Of (B, Loc)))); -- B 7303 7304 -- Generate: 7305 -- Abort_Defer; 7306 7307 Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 7308 7309 -- Generate: 7310 -- Abort_Undefer; 7311 -- <abortable-statements> 7312 7313 Cleanup_Stmts := New_Copy_List_Tree (Astats); 7314 7315 Prepend_To 7316 (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7317 7318 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7319 -- will generate a _clean for the additional status flag. 7320 7321 -- Generate: 7322 -- declare 7323 -- procedure _clean is 7324 -- begin 7325 -- Cancel_Task_Entry_Call (U); 7326 -- end _clean; 7327 -- begin 7328 -- Cleanup_Stmts 7329 -- at end 7330 -- _clean; 7331 -- end; 7332 7333 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7334 Cleanup_Block := 7335 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T); 7336 7337 -- Wrap the cleanup block in an exception handling block 7338 7339 -- Generate: 7340 -- begin 7341 -- Cleanup_Block 7342 -- exception 7343 -- when Abort_Signal => Abort_Undefer; 7344 -- end; 7345 7346 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7347 7348 Append_To (TaskE_Stmts, 7349 Make_Implicit_Label_Declaration (Loc, 7350 Defining_Identifier => Abort_Block_Ent)); 7351 7352 Append_To (TaskE_Stmts, 7353 Build_Abort_Block 7354 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7355 7356 -- Generate: 7357 -- if not T then 7358 -- <triggering-statements> 7359 -- end if; 7360 7361 Append_To (TaskE_Stmts, 7362 Make_Implicit_If_Statement (N, 7363 Condition => 7364 Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)), 7365 7366 Then_Statements => 7367 New_Copy_List_Tree (Tstats))); 7368 7369 ---------------------------------- 7370 -- Protected procedure handling -- 7371 ---------------------------------- 7372 7373 -- Generate: 7374 -- <dispatching-call>; 7375 -- <triggering-statements> 7376 7377 ProtP_Stmts := New_Copy_List_Tree (Tstats); 7378 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall)); 7379 7380 -- Generate: 7381 -- S := Ada.Tags.Get_Offset_Index 7382 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 7383 7384 Conc_Typ_Stmts := 7385 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 7386 7387 -- Generate: 7388 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 7389 7390 Append_To (Conc_Typ_Stmts, 7391 Make_Procedure_Call_Statement (Loc, 7392 Name => 7393 New_Occurrence_Of 7394 (Find_Prim_Op (Etype (Etype (Obj)), 7395 Name_uDisp_Get_Prim_Op_Kind), 7396 Loc), 7397 Parameter_Associations => 7398 New_List ( 7399 New_Copy_Tree (Obj), 7400 New_Occurrence_Of (S, Loc), 7401 New_Occurrence_Of (C, Loc)))); 7402 7403 -- Generate: 7404 -- if C = POK_Procedure_Entry then 7405 -- ProtE_Stmts 7406 -- elsif C = POK_Task_Entry then 7407 -- TaskE_Stmts 7408 -- else 7409 -- ProtP_Stmts 7410 -- end if; 7411 7412 Append_To (Conc_Typ_Stmts, 7413 Make_Implicit_If_Statement (N, 7414 Condition => 7415 Make_Op_Eq (Loc, 7416 Left_Opnd => 7417 New_Occurrence_Of (C, Loc), 7418 Right_Opnd => 7419 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 7420 7421 Then_Statements => 7422 ProtE_Stmts, 7423 7424 Elsif_Parts => 7425 New_List ( 7426 Make_Elsif_Part (Loc, 7427 Condition => 7428 Make_Op_Eq (Loc, 7429 Left_Opnd => 7430 New_Occurrence_Of (C, Loc), 7431 Right_Opnd => 7432 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)), 7433 7434 Then_Statements => 7435 TaskE_Stmts)), 7436 7437 Else_Statements => 7438 ProtP_Stmts)); 7439 7440 -- Generate: 7441 -- <dispatching-call>; 7442 -- <triggering-statements> 7443 7444 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats); 7445 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall)); 7446 7447 -- Generate: 7448 -- if K = Ada.Tags.TK_Limited_Tagged 7449 -- or else K = Ada.Tags.TK_Tagged 7450 -- then 7451 -- Lim_Typ_Stmts 7452 -- else 7453 -- Conc_Typ_Stmts 7454 -- end if; 7455 7456 Append_To (Stmts, 7457 Make_Implicit_If_Statement (N, 7458 Condition => Build_Dispatching_Tag_Check (K, N), 7459 Then_Statements => Lim_Typ_Stmts, 7460 Else_Statements => Conc_Typ_Stmts)); 7461 7462 Rewrite (N, 7463 Make_Block_Statement (Loc, 7464 Declarations => 7465 Decls, 7466 Handled_Statement_Sequence => 7467 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7468 7469 Analyze (N); 7470 return; 7471 7472 -- Delay triggering statement processing 7473 7474 else 7475 -- Add a Delay_Block object to the parameter list of the delay 7476 -- procedure to form the parameter list of the Wait entry call. 7477 7478 Dblock_Ent := Make_Temporary (Loc, 'D'); 7479 7480 Pdef := Entity (Name (Ecall)); 7481 7482 if Is_RTE (Pdef, RO_CA_Delay_For) then 7483 Enqueue_Call := 7484 New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc); 7485 7486 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then 7487 Enqueue_Call := 7488 New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc); 7489 7490 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); 7491 Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc); 7492 end if; 7493 7494 Append_To (Parameter_Associations (Ecall), 7495 Make_Attribute_Reference (Loc, 7496 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7497 Attribute_Name => Name_Unchecked_Access)); 7498 7499 -- Create the inner block to protect the abortable part 7500 7501 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7502 7503 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7504 7505 Abortable_Block := 7506 Make_Block_Statement (Loc, 7507 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7508 Handled_Statement_Sequence => 7509 Make_Handled_Sequence_Of_Statements (Loc, 7510 Statements => Astats), 7511 Has_Created_Identifier => True, 7512 Is_Asynchronous_Call_Block => True); 7513 7514 -- Append call to if Enqueue (When, DB'Unchecked_Access) then 7515 7516 Rewrite (Ecall, 7517 Make_Implicit_If_Statement (N, 7518 Condition => 7519 Make_Function_Call (Loc, 7520 Name => Enqueue_Call, 7521 Parameter_Associations => Parameter_Associations (Ecall)), 7522 Then_Statements => 7523 New_List (Make_Block_Statement (Loc, 7524 Handled_Statement_Sequence => 7525 Make_Handled_Sequence_Of_Statements (Loc, 7526 Statements => New_List ( 7527 Make_Implicit_Label_Declaration (Loc, 7528 Defining_Identifier => Blk_Ent, 7529 Label_Construct => Abortable_Block), 7530 Abortable_Block), 7531 Exception_Handlers => Hdle))))); 7532 7533 Stmts := New_List (Ecall); 7534 7535 -- Construct statement sequence for new block 7536 7537 Append_To (Stmts, 7538 Make_Implicit_If_Statement (N, 7539 Condition => 7540 Make_Function_Call (Loc, 7541 Name => New_Occurrence_Of ( 7542 RTE (RE_Timed_Out), Loc), 7543 Parameter_Associations => New_List ( 7544 Make_Attribute_Reference (Loc, 7545 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7546 Attribute_Name => Name_Unchecked_Access))), 7547 Then_Statements => Tstats)); 7548 7549 -- The result is the new block 7550 7551 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent); 7552 7553 Rewrite (N, 7554 Make_Block_Statement (Loc, 7555 Declarations => New_List ( 7556 Make_Object_Declaration (Loc, 7557 Defining_Identifier => Dblock_Ent, 7558 Aliased_Present => True, 7559 Object_Definition => 7560 New_Occurrence_Of (RTE (RE_Delay_Block), Loc))), 7561 7562 Handled_Statement_Sequence => 7563 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7564 7565 Analyze (N); 7566 return; 7567 end if; 7568 7569 else 7570 N_Orig := N; 7571 end if; 7572 7573 Extract_Entry (Ecall, Concval, Ename, Index); 7574 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index); 7575 7576 Stmts := Statements (Handled_Statement_Sequence (Ecall)); 7577 Decls := Declarations (Ecall); 7578 7579 if Is_Protected_Type (Etype (Concval)) then 7580 7581 -- Get the declarations of the block expanded from the entry call 7582 7583 Decl := First (Decls); 7584 while Present (Decl) 7585 and then (Nkind (Decl) /= N_Object_Declaration 7586 or else not Is_RTE (Etype (Object_Definition (Decl)), 7587 RE_Communication_Block)) 7588 loop 7589 Next (Decl); 7590 end loop; 7591 7592 pragma Assert (Present (Decl)); 7593 Cancel_Param := Defining_Identifier (Decl); 7594 7595 -- Change the mode of the Protected_Entry_Call call 7596 7597 -- Protected_Entry_Call ( 7598 -- Object => po._object'Access, 7599 -- E => <entry index>; 7600 -- Uninterpreted_Data => P'Address; 7601 -- Mode => Asynchronous_Call; 7602 -- Block => Bnn); 7603 7604 -- Skip assignments to temporaries created for in-out parameters 7605 7606 -- This makes unwarranted assumptions about the shape of the expanded 7607 -- tree for the call, and should be cleaned up ??? 7608 7609 Stmt := First (Stmts); 7610 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7611 Next (Stmt); 7612 end loop; 7613 7614 Call := Stmt; 7615 7616 Param := First (Parameter_Associations (Call)); 7617 while Present (Param) 7618 and then not Is_RTE (Etype (Param), RE_Call_Modes) 7619 loop 7620 Next (Param); 7621 end loop; 7622 7623 pragma Assert (Present (Param)); 7624 Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7625 Analyze (Param); 7626 7627 -- Append an if statement to execute the abortable part 7628 7629 -- Generate: 7630 -- if Enqueued (Bnn) then 7631 7632 Append_To (Stmts, 7633 Make_Implicit_If_Statement (N, 7634 Condition => 7635 Make_Function_Call (Loc, 7636 Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7637 Parameter_Associations => New_List ( 7638 New_Occurrence_Of (Cancel_Param, Loc))), 7639 Then_Statements => Astats)); 7640 7641 Abortable_Block := 7642 Make_Block_Statement (Loc, 7643 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7644 Handled_Statement_Sequence => 7645 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts), 7646 Has_Created_Identifier => True, 7647 Is_Asynchronous_Call_Block => True); 7648 7649 -- Aborts are not deferred at beginning of exception handlers in 7650 -- ZCX mode. 7651 7652 if ZCX_Exceptions then 7653 Handler_Stmt := Make_Null_Statement (Loc); 7654 7655 else 7656 Handler_Stmt := Build_Runtime_Call (Loc, RE_Abort_Undefer); 7657 end if; 7658 7659 Stmts := New_List ( 7660 Make_Block_Statement (Loc, 7661 Handled_Statement_Sequence => 7662 Make_Handled_Sequence_Of_Statements (Loc, 7663 Statements => New_List ( 7664 Make_Implicit_Label_Declaration (Loc, 7665 Defining_Identifier => Blk_Ent, 7666 Label_Construct => Abortable_Block), 7667 Abortable_Block), 7668 7669 -- exception 7670 7671 Exception_Handlers => New_List ( 7672 Make_Implicit_Exception_Handler (Loc, 7673 7674 -- when Abort_Signal => 7675 -- Abort_Undefer.all; 7676 7677 Exception_Choices => 7678 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)), 7679 Statements => New_List (Handler_Stmt))))), 7680 7681 -- if not Cancelled (Bnn) then 7682 -- triggered statements 7683 -- end if; 7684 7685 Make_Implicit_If_Statement (N, 7686 Condition => Make_Op_Not (Loc, 7687 Right_Opnd => 7688 Make_Function_Call (Loc, 7689 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7690 Parameter_Associations => New_List ( 7691 New_Occurrence_Of (Cancel_Param, Loc)))), 7692 Then_Statements => Tstats)); 7693 7694 -- Asynchronous task entry call 7695 7696 else 7697 if No (Decls) then 7698 Decls := New_List; 7699 end if; 7700 7701 B := Make_Defining_Identifier (Loc, Name_uB); 7702 7703 -- Insert declaration of B in declarations of existing block 7704 7705 Prepend_To (Decls, 7706 Make_Object_Declaration (Loc, 7707 Defining_Identifier => B, 7708 Object_Definition => 7709 New_Occurrence_Of (Standard_Boolean, Loc))); 7710 7711 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC); 7712 7713 -- Insert the declaration of C in the declarations of the existing 7714 -- block. The variable is initialized to something (True or False, 7715 -- does not matter) to prevent CodePeer from complaining about a 7716 -- possible read of an uninitialized variable. 7717 7718 Prepend_To (Decls, 7719 Make_Object_Declaration (Loc, 7720 Defining_Identifier => Cancel_Param, 7721 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 7722 Expression => New_Occurrence_Of (Standard_False, Loc), 7723 Has_Init_Expression => True)); 7724 7725 -- Remove and save the call to Call_Simple 7726 7727 Stmt := First (Stmts); 7728 7729 -- Skip assignments to temporaries created for in-out parameters. 7730 -- This makes unwarranted assumptions about the shape of the expanded 7731 -- tree for the call, and should be cleaned up ??? 7732 7733 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7734 Next (Stmt); 7735 end loop; 7736 7737 Call := Stmt; 7738 7739 -- Create the inner block to protect the abortable part 7740 7741 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7742 7743 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7744 7745 Abortable_Block := 7746 Make_Block_Statement (Loc, 7747 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7748 Handled_Statement_Sequence => 7749 Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats), 7750 Has_Created_Identifier => True, 7751 Is_Asynchronous_Call_Block => True); 7752 7753 Insert_After (Call, 7754 Make_Block_Statement (Loc, 7755 Handled_Statement_Sequence => 7756 Make_Handled_Sequence_Of_Statements (Loc, 7757 Statements => New_List ( 7758 Make_Implicit_Label_Declaration (Loc, 7759 Defining_Identifier => Blk_Ent, 7760 Label_Construct => Abortable_Block), 7761 Abortable_Block), 7762 Exception_Handlers => Hdle))); 7763 7764 -- Create new call statement 7765 7766 Params := Parameter_Associations (Call); 7767 7768 Append_To (Params, 7769 New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7770 Append_To (Params, New_Occurrence_Of (B, Loc)); 7771 7772 Rewrite (Call, 7773 Make_Procedure_Call_Statement (Loc, 7774 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 7775 Parameter_Associations => Params)); 7776 7777 -- Construct statement sequence for new block 7778 7779 Append_To (Stmts, 7780 Make_Implicit_If_Statement (N, 7781 Condition => 7782 Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)), 7783 Then_Statements => Tstats)); 7784 7785 -- Protected the call against abort 7786 7787 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 7788 end if; 7789 7790 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param); 7791 7792 -- The result is the new block 7793 7794 Rewrite (N_Orig, 7795 Make_Block_Statement (Loc, 7796 Declarations => Decls, 7797 Handled_Statement_Sequence => 7798 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7799 7800 Analyze (N_Orig); 7801 end Expand_N_Asynchronous_Select; 7802 7803 ------------------------------------- 7804 -- Expand_N_Conditional_Entry_Call -- 7805 ------------------------------------- 7806 7807 -- The conditional task entry call is converted to a call to 7808 -- Task_Entry_Call: 7809 7810 -- declare 7811 -- B : Boolean; 7812 -- P : parms := (parm, parm, parm); 7813 7814 -- begin 7815 -- Task_Entry_Call 7816 -- (<acceptor-task>, -- Acceptor 7817 -- <entry-index>, -- E 7818 -- P'Address, -- Uninterpreted_Data 7819 -- Conditional_Call, -- Mode 7820 -- B); -- Rendezvous_Successful 7821 -- parm := P.param; 7822 -- parm := P.param; 7823 -- ... 7824 -- if B then 7825 -- normal-statements 7826 -- else 7827 -- else-statements 7828 -- end if; 7829 -- end; 7830 7831 -- For a description of the use of P and the assignments after the call, 7832 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the 7833 -- conditional entry call has already been expanded (by the Expand_N_Entry 7834 -- _Call_Statement procedure) as follows: 7835 7836 -- declare 7837 -- P : parms := (parm, parm, parm); 7838 -- begin 7839 -- ... info for in-out parameters 7840 -- Call_Simple (acceptor-task, entry-index, P'Address); 7841 -- parm := P.param; 7842 -- parm := P.param; 7843 -- ... 7844 -- end; 7845 7846 -- so the task at hand is to convert the latter expansion into the former 7847 7848 -- The conditional protected entry call is converted to a call to 7849 -- Protected_Entry_Call: 7850 7851 -- declare 7852 -- P : parms := (parm, parm, parm); 7853 -- Bnn : Communications_Block; 7854 7855 -- begin 7856 -- Protected_Entry_Call 7857 -- (po._object'Access, -- Object 7858 -- <entry index>, -- E 7859 -- P'Address, -- Uninterpreted_Data 7860 -- Conditional_Call, -- Mode 7861 -- Bnn); -- Block 7862 -- parm := P.param; 7863 -- parm := P.param; 7864 -- ... 7865 -- if Cancelled (Bnn) then 7866 -- else-statements 7867 -- else 7868 -- normal-statements 7869 -- end if; 7870 -- end; 7871 7872 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted 7873 -- into: 7874 7875 -- declare 7876 -- B : Boolean := False; 7877 -- C : Ada.Tags.Prim_Op_Kind; 7878 -- K : Ada.Tags.Tagged_Kind := 7879 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7880 -- P : Parameters := (Param1 .. ParamN); 7881 -- S : Integer; 7882 7883 -- begin 7884 -- if K = Ada.Tags.TK_Limited_Tagged 7885 -- or else K = Ada.Tags.TK_Tagged 7886 -- then 7887 -- <dispatching-call>; 7888 -- <triggering-statements> 7889 7890 -- else 7891 -- S := 7892 -- Ada.Tags.Get_Offset_Index 7893 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 7894 7895 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 7896 7897 -- if C = POK_Protected_Entry 7898 -- or else C = POK_Task_Entry 7899 -- then 7900 -- Param1 := P.Param1; 7901 -- ... 7902 -- ParamN := P.ParamN; 7903 -- end if; 7904 7905 -- if B then 7906 -- if C = POK_Procedure 7907 -- or else C = POK_Protected_Procedure 7908 -- or else C = POK_Task_Procedure 7909 -- then 7910 -- <dispatching-call>; 7911 -- end if; 7912 7913 -- <triggering-statements> 7914 -- else 7915 -- <else-statements> 7916 -- end if; 7917 -- end if; 7918 -- end; 7919 7920 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is 7921 Loc : constant Source_Ptr := Sloc (N); 7922 Alt : constant Node_Id := Entry_Call_Alternative (N); 7923 Blk : Node_Id := Entry_Call_Statement (Alt); 7924 7925 Actuals : List_Id; 7926 Blk_Typ : Entity_Id; 7927 Call : Node_Id; 7928 Call_Ent : Entity_Id; 7929 Conc_Typ_Stmts : List_Id; 7930 Decl : Node_Id; 7931 Decls : List_Id; 7932 Formals : List_Id; 7933 Lim_Typ_Stmts : List_Id; 7934 N_Stats : List_Id; 7935 Obj : Entity_Id; 7936 Param : Node_Id; 7937 Params : List_Id; 7938 Stmt : Node_Id; 7939 Stmts : List_Id; 7940 Transient_Blk : Node_Id; 7941 Unpack : List_Id; 7942 7943 B : Entity_Id; -- Call status flag 7944 C : Entity_Id; -- Call kind 7945 K : Entity_Id; -- Tagged kind 7946 P : Entity_Id; -- Parameter block 7947 S : Entity_Id; -- Primitive operation slot 7948 7949 begin 7950 Process_Statements_For_Controlled_Objects (N); 7951 7952 if Ada_Version >= Ada_2005 7953 and then Nkind (Blk) = N_Procedure_Call_Statement 7954 then 7955 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals); 7956 7957 Decls := New_List; 7958 Stmts := New_List; 7959 7960 -- Call status flag processing, generate: 7961 -- B : Boolean := False; 7962 7963 B := Build_B (Loc, Decls); 7964 7965 -- Call kind processing, generate: 7966 -- C : Ada.Tags.Prim_Op_Kind; 7967 7968 C := Build_C (Loc, Decls); 7969 7970 -- Tagged kind processing, generate: 7971 -- K : Ada.Tags.Tagged_Kind := 7972 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7973 7974 K := Build_K (Loc, Decls, Obj); 7975 7976 -- Parameter block processing 7977 7978 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 7979 P := Parameter_Block_Pack 7980 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 7981 7982 -- Dispatch table slot processing, generate: 7983 -- S : Integer; 7984 7985 S := Build_S (Loc, Decls); 7986 7987 -- Generate: 7988 -- S := Ada.Tags.Get_Offset_Index 7989 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 7990 7991 Conc_Typ_Stmts := 7992 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 7993 7994 -- Generate: 7995 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 7996 7997 Append_To (Conc_Typ_Stmts, 7998 Make_Procedure_Call_Statement (Loc, 7999 Name => 8000 New_Occurrence_Of ( 8001 Find_Prim_Op (Etype (Etype (Obj)), 8002 Name_uDisp_Conditional_Select), 8003 Loc), 8004 Parameter_Associations => 8005 New_List ( 8006 New_Copy_Tree (Obj), -- <object> 8007 New_Occurrence_Of (S, Loc), -- S 8008 Make_Attribute_Reference (Loc, -- P'Address 8009 Prefix => New_Occurrence_Of (P, Loc), 8010 Attribute_Name => Name_Address), 8011 New_Occurrence_Of (C, Loc), -- C 8012 New_Occurrence_Of (B, Loc)))); -- B 8013 8014 -- Generate: 8015 -- if C = POK_Protected_Entry 8016 -- or else C = POK_Task_Entry 8017 -- then 8018 -- Param1 := P.Param1; 8019 -- ... 8020 -- ParamN := P.ParamN; 8021 -- end if; 8022 8023 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 8024 8025 -- Generate the if statement only when the packed parameters need 8026 -- explicit assignments to their corresponding actuals. 8027 8028 if Present (Unpack) then 8029 Append_To (Conc_Typ_Stmts, 8030 Make_Implicit_If_Statement (N, 8031 Condition => 8032 Make_Or_Else (Loc, 8033 Left_Opnd => 8034 Make_Op_Eq (Loc, 8035 Left_Opnd => 8036 New_Occurrence_Of (C, Loc), 8037 Right_Opnd => 8038 New_Occurrence_Of (RTE ( 8039 RE_POK_Protected_Entry), Loc)), 8040 8041 Right_Opnd => 8042 Make_Op_Eq (Loc, 8043 Left_Opnd => 8044 New_Occurrence_Of (C, Loc), 8045 Right_Opnd => 8046 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 8047 8048 Then_Statements => Unpack)); 8049 end if; 8050 8051 -- Generate: 8052 -- if B then 8053 -- if C = POK_Procedure 8054 -- or else C = POK_Protected_Procedure 8055 -- or else C = POK_Task_Procedure 8056 -- then 8057 -- <dispatching-call> 8058 -- end if; 8059 -- <normal-statements> 8060 -- else 8061 -- <else-statements> 8062 -- end if; 8063 8064 N_Stats := New_Copy_List_Tree (Statements (Alt)); 8065 8066 Prepend_To (N_Stats, 8067 Make_Implicit_If_Statement (N, 8068 Condition => 8069 Make_Or_Else (Loc, 8070 Left_Opnd => 8071 Make_Op_Eq (Loc, 8072 Left_Opnd => 8073 New_Occurrence_Of (C, Loc), 8074 Right_Opnd => 8075 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 8076 8077 Right_Opnd => 8078 Make_Or_Else (Loc, 8079 Left_Opnd => 8080 Make_Op_Eq (Loc, 8081 Left_Opnd => 8082 New_Occurrence_Of (C, Loc), 8083 Right_Opnd => 8084 New_Occurrence_Of (RTE ( 8085 RE_POK_Protected_Procedure), Loc)), 8086 8087 Right_Opnd => 8088 Make_Op_Eq (Loc, 8089 Left_Opnd => 8090 New_Occurrence_Of (C, Loc), 8091 Right_Opnd => 8092 New_Occurrence_Of (RTE ( 8093 RE_POK_Task_Procedure), Loc)))), 8094 8095 Then_Statements => 8096 New_List (Blk))); 8097 8098 Append_To (Conc_Typ_Stmts, 8099 Make_Implicit_If_Statement (N, 8100 Condition => New_Occurrence_Of (B, Loc), 8101 Then_Statements => N_Stats, 8102 Else_Statements => Else_Statements (N))); 8103 8104 -- Generate: 8105 -- <dispatching-call>; 8106 -- <triggering-statements> 8107 8108 Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt)); 8109 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); 8110 8111 -- Generate: 8112 -- if K = Ada.Tags.TK_Limited_Tagged 8113 -- or else K = Ada.Tags.TK_Tagged 8114 -- then 8115 -- Lim_Typ_Stmts 8116 -- else 8117 -- Conc_Typ_Stmts 8118 -- end if; 8119 8120 Append_To (Stmts, 8121 Make_Implicit_If_Statement (N, 8122 Condition => Build_Dispatching_Tag_Check (K, N), 8123 Then_Statements => Lim_Typ_Stmts, 8124 Else_Statements => Conc_Typ_Stmts)); 8125 8126 Rewrite (N, 8127 Make_Block_Statement (Loc, 8128 Declarations => 8129 Decls, 8130 Handled_Statement_Sequence => 8131 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8132 8133 -- As described above, the entry alternative is transformed into a 8134 -- block that contains the gnulli call, and possibly assignment 8135 -- statements for in-out parameters. The gnulli call may itself be 8136 -- rewritten into a transient block if some unconstrained parameters 8137 -- require it. We need to retrieve the call to complete its parameter 8138 -- list. 8139 8140 else 8141 Transient_Blk := 8142 First_Real_Statement (Handled_Statement_Sequence (Blk)); 8143 8144 if Present (Transient_Blk) 8145 and then Nkind (Transient_Blk) = N_Block_Statement 8146 then 8147 Blk := Transient_Blk; 8148 end if; 8149 8150 Stmts := Statements (Handled_Statement_Sequence (Blk)); 8151 Stmt := First (Stmts); 8152 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 8153 Next (Stmt); 8154 end loop; 8155 8156 Call := Stmt; 8157 Params := Parameter_Associations (Call); 8158 8159 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then 8160 8161 -- Substitute Conditional_Entry_Call for Simple_Call parameter 8162 8163 Param := First (Params); 8164 while Present (Param) 8165 and then not Is_RTE (Etype (Param), RE_Call_Modes) 8166 loop 8167 Next (Param); 8168 end loop; 8169 8170 pragma Assert (Present (Param)); 8171 Rewrite (Param, 8172 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8173 8174 Analyze (Param); 8175 8176 -- Find the Communication_Block parameter for the call to the 8177 -- Cancelled function. 8178 8179 Decl := First (Declarations (Blk)); 8180 while Present (Decl) 8181 and then not Is_RTE (Etype (Object_Definition (Decl)), 8182 RE_Communication_Block) 8183 loop 8184 Next (Decl); 8185 end loop; 8186 8187 -- Add an if statement to execute the else part if the call 8188 -- does not succeed (as indicated by the Cancelled predicate). 8189 8190 Append_To (Stmts, 8191 Make_Implicit_If_Statement (N, 8192 Condition => Make_Function_Call (Loc, 8193 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 8194 Parameter_Associations => New_List ( 8195 New_Occurrence_Of (Defining_Identifier (Decl), Loc))), 8196 Then_Statements => Else_Statements (N), 8197 Else_Statements => Statements (Alt))); 8198 8199 else 8200 B := Make_Defining_Identifier (Loc, Name_uB); 8201 8202 -- Insert declaration of B in declarations of existing block 8203 8204 if No (Declarations (Blk)) then 8205 Set_Declarations (Blk, New_List); 8206 end if; 8207 8208 Prepend_To (Declarations (Blk), 8209 Make_Object_Declaration (Loc, 8210 Defining_Identifier => B, 8211 Object_Definition => 8212 New_Occurrence_Of (Standard_Boolean, Loc))); 8213 8214 -- Create new call statement 8215 8216 Append_To (Params, 8217 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8218 Append_To (Params, New_Occurrence_Of (B, Loc)); 8219 8220 Rewrite (Call, 8221 Make_Procedure_Call_Statement (Loc, 8222 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 8223 Parameter_Associations => Params)); 8224 8225 -- Construct statement sequence for new block 8226 8227 Append_To (Stmts, 8228 Make_Implicit_If_Statement (N, 8229 Condition => New_Occurrence_Of (B, Loc), 8230 Then_Statements => Statements (Alt), 8231 Else_Statements => Else_Statements (N))); 8232 end if; 8233 8234 -- The result is the new block 8235 8236 Rewrite (N, 8237 Make_Block_Statement (Loc, 8238 Declarations => Declarations (Blk), 8239 Handled_Statement_Sequence => 8240 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8241 end if; 8242 8243 Analyze (N); 8244 8245 Reset_Scopes_To (N, Entity (Identifier (N))); 8246 end Expand_N_Conditional_Entry_Call; 8247 8248 --------------------------------------- 8249 -- Expand_N_Delay_Relative_Statement -- 8250 --------------------------------------- 8251 8252 -- Delay statement is implemented as a procedure call to Delay_For 8253 -- defined in Ada.Calendar.Delays in order to reduce the overhead of 8254 -- simple delays imposed by the use of Protected Objects. 8255 8256 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is 8257 Loc : constant Source_Ptr := Sloc (N); 8258 Proc : Entity_Id; 8259 8260 begin 8261 -- Try to use Ada.Calendar.Delays.Delay_For if available. 8262 8263 if RTE_Available (RO_CA_Delay_For) then 8264 Proc := RTE (RO_CA_Delay_For); 8265 8266 -- Otherwise, use System.Relative_Delays.Delay_For and emit an error 8267 -- message if not available. This is the implementation used on 8268 -- restricted platforms when Ada.Calendar is not available. 8269 8270 else 8271 Proc := RTE (RO_RD_Delay_For); 8272 end if; 8273 8274 Rewrite (N, 8275 Make_Procedure_Call_Statement (Loc, 8276 Name => New_Occurrence_Of (Proc, Loc), 8277 Parameter_Associations => New_List (Expression (N)))); 8278 Analyze (N); 8279 end Expand_N_Delay_Relative_Statement; 8280 8281 ------------------------------------ 8282 -- Expand_N_Delay_Until_Statement -- 8283 ------------------------------------ 8284 8285 -- Delay Until statement is implemented as a procedure call to 8286 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays. 8287 8288 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is 8289 Loc : constant Source_Ptr := Sloc (N); 8290 Typ : Entity_Id; 8291 8292 begin 8293 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then 8294 Typ := RTE (RO_CA_Delay_Until); 8295 else 8296 Typ := RTE (RO_RT_Delay_Until); 8297 end if; 8298 8299 Rewrite (N, 8300 Make_Procedure_Call_Statement (Loc, 8301 Name => New_Occurrence_Of (Typ, Loc), 8302 Parameter_Associations => New_List (Expression (N)))); 8303 8304 Analyze (N); 8305 end Expand_N_Delay_Until_Statement; 8306 8307 ------------------------- 8308 -- Expand_N_Entry_Body -- 8309 ------------------------- 8310 8311 procedure Expand_N_Entry_Body (N : Node_Id) is 8312 begin 8313 -- Associate discriminals with the next protected operation body to be 8314 -- expanded. 8315 8316 if Present (Next_Protected_Operation (N)) then 8317 Set_Discriminals (Parent (Current_Scope)); 8318 end if; 8319 end Expand_N_Entry_Body; 8320 8321 ----------------------------------- 8322 -- Expand_N_Entry_Call_Statement -- 8323 ----------------------------------- 8324 8325 -- An entry call is expanded into GNARLI calls to implement a simple entry 8326 -- call (see Build_Simple_Entry_Call). 8327 8328 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is 8329 Concval : Node_Id; 8330 Ename : Node_Id; 8331 Index : Node_Id; 8332 8333 begin 8334 if No_Run_Time_Mode then 8335 Error_Msg_CRT ("entry call", N); 8336 return; 8337 end if; 8338 8339 -- If this entry call is part of an asynchronous select, don't expand it 8340 -- here; it will be expanded with the select statement. Don't expand 8341 -- timed entry calls either, as they are translated into asynchronous 8342 -- entry calls. 8343 8344 -- ??? This whole approach is questionable; it may be better to go back 8345 -- to allowing the expansion to take place and then attempting to fix it 8346 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out 8347 -- whether the expanded call is on a task or protected entry. 8348 8349 if (Nkind (Parent (N)) /= N_Triggering_Alternative 8350 or else N /= Triggering_Statement (Parent (N))) 8351 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative 8352 or else N /= Entry_Call_Statement (Parent (N)) 8353 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call) 8354 then 8355 Extract_Entry (N, Concval, Ename, Index); 8356 Build_Simple_Entry_Call (N, Concval, Ename, Index); 8357 end if; 8358 end Expand_N_Entry_Call_Statement; 8359 8360 -------------------------------- 8361 -- Expand_N_Entry_Declaration -- 8362 -------------------------------- 8363 8364 -- If there are parameters, then first, each of the formals is marked by 8365 -- setting Is_Entry_Formal. Next a record type is built which is used to 8366 -- hold the parameter values. The name of this record type is entryP where 8367 -- entry is the name of the entry, with an additional corresponding access 8368 -- type called entryPA. The record type has matching components for each 8369 -- formal (the component names are the same as the formal names). For 8370 -- elementary types, the component type matches the formal type. For 8371 -- composite types, an access type is declared (with the name formalA) 8372 -- which designates the formal type, and the type of the component is this 8373 -- access type. Finally the Entry_Component of each formal is set to 8374 -- reference the corresponding record component. 8375 8376 procedure Expand_N_Entry_Declaration (N : Node_Id) is 8377 Loc : constant Source_Ptr := Sloc (N); 8378 Entry_Ent : constant Entity_Id := Defining_Identifier (N); 8379 Components : List_Id; 8380 Formal : Node_Id; 8381 Ftype : Entity_Id; 8382 Last_Decl : Node_Id; 8383 Component : Entity_Id; 8384 Ctype : Entity_Id; 8385 Decl : Node_Id; 8386 Rec_Ent : Entity_Id; 8387 Acc_Ent : Entity_Id; 8388 8389 begin 8390 Formal := First_Formal (Entry_Ent); 8391 Last_Decl := N; 8392 8393 -- Most processing is done only if parameters are present 8394 8395 if Present (Formal) then 8396 Components := New_List; 8397 8398 -- Loop through formals 8399 8400 while Present (Formal) loop 8401 Set_Is_Entry_Formal (Formal); 8402 Component := 8403 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); 8404 Set_Entry_Component (Formal, Component); 8405 Set_Entry_Formal (Component, Formal); 8406 Ftype := Etype (Formal); 8407 8408 -- Declare new access type and then append 8409 8410 Ctype := Make_Temporary (Loc, 'A'); 8411 Set_Is_Param_Block_Component_Type (Ctype); 8412 8413 Decl := 8414 Make_Full_Type_Declaration (Loc, 8415 Defining_Identifier => Ctype, 8416 Type_Definition => 8417 Make_Access_To_Object_Definition (Loc, 8418 All_Present => True, 8419 Constant_Present => Ekind (Formal) = E_In_Parameter, 8420 Subtype_Indication => New_Occurrence_Of (Ftype, Loc))); 8421 8422 Insert_After (Last_Decl, Decl); 8423 Last_Decl := Decl; 8424 8425 Append_To (Components, 8426 Make_Component_Declaration (Loc, 8427 Defining_Identifier => Component, 8428 Component_Definition => 8429 Make_Component_Definition (Loc, 8430 Aliased_Present => False, 8431 Subtype_Indication => New_Occurrence_Of (Ctype, Loc)))); 8432 8433 Next_Formal_With_Extras (Formal); 8434 end loop; 8435 8436 -- Create the Entry_Parameter_Record declaration 8437 8438 Rec_Ent := Make_Temporary (Loc, 'P'); 8439 8440 Decl := 8441 Make_Full_Type_Declaration (Loc, 8442 Defining_Identifier => Rec_Ent, 8443 Type_Definition => 8444 Make_Record_Definition (Loc, 8445 Component_List => 8446 Make_Component_List (Loc, 8447 Component_Items => Components))); 8448 8449 Insert_After (Last_Decl, Decl); 8450 Last_Decl := Decl; 8451 8452 -- Construct and link in the corresponding access type 8453 8454 Acc_Ent := Make_Temporary (Loc, 'A'); 8455 8456 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); 8457 8458 Decl := 8459 Make_Full_Type_Declaration (Loc, 8460 Defining_Identifier => Acc_Ent, 8461 Type_Definition => 8462 Make_Access_To_Object_Definition (Loc, 8463 All_Present => True, 8464 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc))); 8465 8466 Insert_After (Last_Decl, Decl); 8467 end if; 8468 end Expand_N_Entry_Declaration; 8469 8470 ----------------------------- 8471 -- Expand_N_Protected_Body -- 8472 ----------------------------- 8473 8474 -- Protected bodies are expanded to the completion of the subprograms 8475 -- created for the corresponding protected type. These are a protected and 8476 -- unprotected version of each protected subprogram in the object, a 8477 -- function to calculate each entry barrier, and a procedure to execute the 8478 -- sequence of statements of each protected entry body. For example, for 8479 -- protected type ptype: 8480 8481 -- function entB 8482 -- (O : System.Address; 8483 -- E : Protected_Entry_Index) 8484 -- return Boolean 8485 -- is 8486 -- <discriminant renamings> 8487 -- <private object renamings> 8488 -- begin 8489 -- return <barrier expression>; 8490 -- end entB; 8491 8492 -- procedure pprocN (_object : in out poV;...) is 8493 -- <discriminant renamings> 8494 -- <private object renamings> 8495 -- begin 8496 -- <sequence of statements> 8497 -- end pprocN; 8498 8499 -- procedure pprocP (_object : in out poV;...) is 8500 -- procedure _clean is 8501 -- Pn : Boolean; 8502 -- begin 8503 -- ptypeS (_object, Pn); 8504 -- Unlock (_object._object'Access); 8505 -- Abort_Undefer.all; 8506 -- end _clean; 8507 8508 -- begin 8509 -- Abort_Defer.all; 8510 -- Lock (_object._object'Access); 8511 -- pprocN (_object;...); 8512 -- at end 8513 -- _clean; 8514 -- end pproc; 8515 8516 -- function pfuncN (_object : poV;...) return Return_Type is 8517 -- <discriminant renamings> 8518 -- <private object renamings> 8519 -- begin 8520 -- <sequence of statements> 8521 -- end pfuncN; 8522 8523 -- function pfuncP (_object : poV) return Return_Type is 8524 -- procedure _clean is 8525 -- begin 8526 -- Unlock (_object._object'Access); 8527 -- Abort_Undefer.all; 8528 -- end _clean; 8529 8530 -- begin 8531 -- Abort_Defer.all; 8532 -- Lock (_object._object'Access); 8533 -- return pfuncN (_object); 8534 8535 -- at end 8536 -- _clean; 8537 -- end pfunc; 8538 8539 -- procedure entE 8540 -- (O : System.Address; 8541 -- P : System.Address; 8542 -- E : Protected_Entry_Index) 8543 -- is 8544 -- <discriminant renamings> 8545 -- <private object renamings> 8546 -- type poVP is access poV; 8547 -- _Object : ptVP := ptVP!(O); 8548 8549 -- begin 8550 -- begin 8551 -- <statement sequence> 8552 -- Complete_Entry_Body (_Object._Object); 8553 -- exception 8554 -- when all others => 8555 -- Exceptional_Complete_Entry_Body ( 8556 -- _Object._Object, Get_GNAT_Exception); 8557 -- end; 8558 -- end entE; 8559 8560 -- The type poV is the record created for the protected type to hold 8561 -- the state of the protected object. 8562 8563 procedure Expand_N_Protected_Body (N : Node_Id) is 8564 Loc : constant Source_Ptr := Sloc (N); 8565 Pid : constant Entity_Id := Corresponding_Spec (N); 8566 8567 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid); 8568 -- This flag indicates whether the lock free implementation is active 8569 8570 Current_Node : Node_Id; 8571 Disp_Op_Body : Node_Id; 8572 New_Op_Body : Node_Id; 8573 Op_Body : Node_Id; 8574 Op_Id : Entity_Id; 8575 8576 function Build_Dispatching_Subprogram_Body 8577 (N : Node_Id; 8578 Pid : Node_Id; 8579 Prot_Bod : Node_Id) return Node_Id; 8580 -- Build a dispatching version of the protected subprogram body. The 8581 -- newly generated subprogram contains a call to the original protected 8582 -- body. The following code is generated: 8583 -- 8584 -- function <protected-function-name> (Param1 .. ParamN) return 8585 -- <return-type> is 8586 -- begin 8587 -- return <protected-function-name>P (Param1 .. ParamN); 8588 -- end <protected-function-name>; 8589 -- 8590 -- or 8591 -- 8592 -- procedure <protected-procedure-name> (Param1 .. ParamN) is 8593 -- begin 8594 -- <protected-procedure-name>P (Param1 .. ParamN); 8595 -- end <protected-procedure-name> 8596 8597 --------------------------------------- 8598 -- Build_Dispatching_Subprogram_Body -- 8599 --------------------------------------- 8600 8601 function Build_Dispatching_Subprogram_Body 8602 (N : Node_Id; 8603 Pid : Node_Id; 8604 Prot_Bod : Node_Id) return Node_Id 8605 is 8606 Loc : constant Source_Ptr := Sloc (N); 8607 Actuals : List_Id; 8608 Formal : Node_Id; 8609 Spec : Node_Id; 8610 Stmts : List_Id; 8611 8612 begin 8613 -- Generate a specification without a letter suffix in order to 8614 -- override an interface function or procedure. 8615 8616 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode); 8617 8618 -- The formal parameters become the actuals of the protected function 8619 -- or procedure call. 8620 8621 Actuals := New_List; 8622 Formal := First (Parameter_Specifications (Spec)); 8623 while Present (Formal) loop 8624 Append_To (Actuals, 8625 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 8626 Next (Formal); 8627 end loop; 8628 8629 if Nkind (Spec) = N_Procedure_Specification then 8630 Stmts := 8631 New_List ( 8632 Make_Procedure_Call_Statement (Loc, 8633 Name => 8634 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8635 Parameter_Associations => Actuals)); 8636 8637 else 8638 pragma Assert (Nkind (Spec) = N_Function_Specification); 8639 8640 Stmts := 8641 New_List ( 8642 Make_Simple_Return_Statement (Loc, 8643 Expression => 8644 Make_Function_Call (Loc, 8645 Name => 8646 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8647 Parameter_Associations => Actuals))); 8648 end if; 8649 8650 return 8651 Make_Subprogram_Body (Loc, 8652 Declarations => Empty_List, 8653 Specification => Spec, 8654 Handled_Statement_Sequence => 8655 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 8656 end Build_Dispatching_Subprogram_Body; 8657 8658 -- Start of processing for Expand_N_Protected_Body 8659 8660 begin 8661 if No_Run_Time_Mode then 8662 Error_Msg_CRT ("protected body", N); 8663 return; 8664 end if; 8665 8666 -- This is the proper body corresponding to a stub. The declarations 8667 -- must be inserted at the point of the stub, which in turn is in the 8668 -- declarative part of the parent unit. 8669 8670 if Nkind (Parent (N)) = N_Subunit then 8671 Current_Node := Corresponding_Stub (Parent (N)); 8672 else 8673 Current_Node := N; 8674 end if; 8675 8676 Op_Body := First (Declarations (N)); 8677 8678 -- The protected body is replaced with the bodies of its protected 8679 -- operations, and the declarations for internal objects that may 8680 -- have been created for entry family bounds. 8681 8682 Rewrite (N, Make_Null_Statement (Sloc (N))); 8683 Analyze (N); 8684 8685 while Present (Op_Body) loop 8686 case Nkind (Op_Body) is 8687 when N_Subprogram_Declaration => 8688 null; 8689 8690 when N_Subprogram_Body => 8691 8692 -- Do not create bodies for eliminated operations 8693 8694 if not Is_Eliminated (Defining_Entity (Op_Body)) 8695 and then not Is_Eliminated (Corresponding_Spec (Op_Body)) 8696 then 8697 if Lock_Free_Active then 8698 New_Op_Body := 8699 Build_Lock_Free_Unprotected_Subprogram_Body 8700 (Op_Body, Pid); 8701 else 8702 New_Op_Body := 8703 Build_Unprotected_Subprogram_Body (Op_Body, Pid); 8704 end if; 8705 8706 Insert_After (Current_Node, New_Op_Body); 8707 Current_Node := New_Op_Body; 8708 Analyze (New_Op_Body); 8709 8710 -- Build the corresponding protected operation. It may 8711 -- appear that this is needed only if this is a visible 8712 -- operation of the type, or if it is an interrupt handler, 8713 -- and this was the strategy used previously in GNAT. 8714 8715 -- However, the operation may be exported through a 'Access 8716 -- to an external caller. This is the common idiom in code 8717 -- that uses the Ada 2005 Timing_Events package. As a result 8718 -- we need to produce the protected body for both visible 8719 -- and private operations, as well as operations that only 8720 -- have a body in the source, and for which we create a 8721 -- declaration in the protected body itself. 8722 8723 if Present (Corresponding_Spec (Op_Body)) then 8724 if Lock_Free_Active then 8725 New_Op_Body := 8726 Build_Lock_Free_Protected_Subprogram_Body 8727 (Op_Body, Pid, Specification (New_Op_Body)); 8728 else 8729 New_Op_Body := 8730 Build_Protected_Subprogram_Body 8731 (Op_Body, Pid, Specification (New_Op_Body)); 8732 end if; 8733 8734 Insert_After (Current_Node, New_Op_Body); 8735 Analyze (New_Op_Body); 8736 8737 Current_Node := New_Op_Body; 8738 8739 -- Generate an overriding primitive operation body for 8740 -- this subprogram if the protected type implements an 8741 -- interface. 8742 8743 if Ada_Version >= Ada_2005 8744 and then 8745 Present (Interfaces (Corresponding_Record_Type (Pid))) 8746 then 8747 Disp_Op_Body := 8748 Build_Dispatching_Subprogram_Body 8749 (Op_Body, Pid, New_Op_Body); 8750 8751 Insert_After (Current_Node, Disp_Op_Body); 8752 Analyze (Disp_Op_Body); 8753 8754 Current_Node := Disp_Op_Body; 8755 end if; 8756 end if; 8757 end if; 8758 8759 when N_Entry_Body => 8760 Op_Id := Defining_Identifier (Op_Body); 8761 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); 8762 8763 Insert_After (Current_Node, New_Op_Body); 8764 Current_Node := New_Op_Body; 8765 Analyze (New_Op_Body); 8766 8767 when N_Implicit_Label_Declaration => 8768 null; 8769 8770 when N_Call_Marker 8771 | N_Itype_Reference 8772 => 8773 New_Op_Body := New_Copy (Op_Body); 8774 Insert_After (Current_Node, New_Op_Body); 8775 Current_Node := New_Op_Body; 8776 8777 when N_Freeze_Entity => 8778 New_Op_Body := New_Copy (Op_Body); 8779 8780 if Present (Entity (Op_Body)) 8781 and then Freeze_Node (Entity (Op_Body)) = Op_Body 8782 then 8783 Set_Freeze_Node (Entity (Op_Body), New_Op_Body); 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 N_Pragma => 8791 New_Op_Body := New_Copy (Op_Body); 8792 Insert_After (Current_Node, New_Op_Body); 8793 Current_Node := New_Op_Body; 8794 Analyze (New_Op_Body); 8795 8796 when N_Object_Declaration => 8797 pragma Assert (not Comes_From_Source (Op_Body)); 8798 New_Op_Body := New_Copy (Op_Body); 8799 Insert_After (Current_Node, New_Op_Body); 8800 Current_Node := New_Op_Body; 8801 Analyze (New_Op_Body); 8802 8803 when others => 8804 raise Program_Error; 8805 end case; 8806 8807 Next (Op_Body); 8808 end loop; 8809 8810 -- Finally, create the body of the function that maps an entry index 8811 -- into the corresponding body index, except when there is no entry, or 8812 -- in a Ravenscar-like profile. 8813 8814 if Corresponding_Runtime_Package (Pid) = 8815 System_Tasking_Protected_Objects_Entries 8816 then 8817 New_Op_Body := Build_Find_Body_Index (Pid); 8818 Insert_After (Current_Node, New_Op_Body); 8819 Current_Node := New_Op_Body; 8820 Analyze (New_Op_Body); 8821 end if; 8822 8823 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the 8824 -- protected body. At this point all wrapper specs have been created, 8825 -- frozen and included in the dispatch table for the protected type. 8826 8827 if Ada_Version >= Ada_2005 then 8828 Build_Wrapper_Bodies (Loc, Pid, Current_Node); 8829 end if; 8830 end Expand_N_Protected_Body; 8831 8832 ----------------------------------------- 8833 -- Expand_N_Protected_Type_Declaration -- 8834 ----------------------------------------- 8835 8836 -- First we create a corresponding record type declaration used to 8837 -- represent values of this protected type. 8838 -- The general form of this type declaration is 8839 8840 -- type poV (discriminants) is record 8841 -- _Object : aliased <kind>Protection 8842 -- [(<entry count> [, <handler count>])]; 8843 -- [entry_family : array (bounds) of Void;] 8844 -- <private data fields> 8845 -- end record; 8846 8847 -- The discriminants are present only if the corresponding protected type 8848 -- has discriminants, and they exactly mirror the protected type 8849 -- discriminants. The private data fields similarly mirror the private 8850 -- declarations of the protected type. 8851 8852 -- The Object field is always present. It contains RTS specific data used 8853 -- to control the protected object. It is declared as Aliased so that it 8854 -- can be passed as a pointer to the RTS. This allows the protected record 8855 -- to be referenced within RTS data structures. An appropriate Protection 8856 -- type and discriminant are generated. 8857 8858 -- The Service field is present for protected objects with entries. It 8859 -- contains sufficient information to allow the entry service procedure for 8860 -- this object to be called when the object is not known till runtime. 8861 8862 -- One entry_family component is present for each entry family in the 8863 -- task definition (see Expand_N_Task_Type_Declaration). 8864 8865 -- When a protected object is declared, an instance of the protected type 8866 -- value record is created. The elaboration of this declaration creates the 8867 -- correct bounds for the entry families, and also evaluates the priority 8868 -- expression if needed. The initialization routine for the protected type 8869 -- itself then calls Initialize_Protection with appropriate parameters to 8870 -- initialize the value of the Task_Id field. Install_Handlers may be also 8871 -- called if a pragma Attach_Handler applies. 8872 8873 -- Note: this record is passed to the subprograms created by the expansion 8874 -- of protected subprograms and entries. It is an in parameter to protected 8875 -- functions and an in out parameter to procedures and entry bodies. The 8876 -- Entity_Id for this created record type is placed in the 8877 -- Corresponding_Record_Type field of the associated protected type entity. 8878 8879 -- Next we create a procedure specifications for protected subprograms and 8880 -- entry bodies. For each protected subprograms two subprograms are 8881 -- created, an unprotected and a protected version. The unprotected version 8882 -- is called from within other operations of the same protected object. 8883 8884 -- We also build the call to register the procedure if a pragma 8885 -- Interrupt_Handler applies. 8886 8887 -- A single subprogram is created to service all entry bodies; it has an 8888 -- additional boolean out parameter indicating that the previous entry call 8889 -- made by the current task was serviced immediately, i.e. not by proxy. 8890 -- The O parameter contains a pointer to a record object of the type 8891 -- described above. An untyped interface is used here to allow this 8892 -- procedure to be called in places where the type of the object to be 8893 -- serviced is not known. This must be done, for example, when a call that 8894 -- may have been requeued is cancelled; the corresponding object must be 8895 -- serviced, but which object that is not known till runtime. 8896 8897 -- procedure ptypeS 8898 -- (O : System.Address; P : out Boolean); 8899 -- procedure pprocN (_object : in out poV); 8900 -- procedure pproc (_object : in out poV); 8901 -- function pfuncN (_object : poV); 8902 -- function pfunc (_object : poV); 8903 -- ... 8904 8905 -- Note that this must come after the record type declaration, since 8906 -- the specs refer to this type. 8907 8908 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is 8909 Discr_Map : constant Elist_Id := New_Elmt_List; 8910 Loc : constant Source_Ptr := Sloc (N); 8911 Prot_Typ : constant Entity_Id := Defining_Identifier (N); 8912 8913 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ); 8914 -- This flag indicates whether the lock free implementation is active 8915 8916 Pdef : constant Node_Id := Protected_Definition (N); 8917 -- This contains two lists; one for visible and one for private decls 8918 8919 Current_Node : Node_Id := N; 8920 E_Count : Int; 8921 Entries_Aggr : Node_Id; 8922 8923 procedure Check_Inlining (Subp : Entity_Id); 8924 -- If the original operation has a pragma Inline, propagate the flag 8925 -- to the internal body, for possible inlining later on. The source 8926 -- operation is invisible to the back-end and is never actually called. 8927 8928 procedure Expand_Entry_Declaration (Decl : Node_Id); 8929 -- Create the entry barrier and the procedure body for entry declaration 8930 -- Decl. All generated subprograms are added to Entry_Bodies_Array. 8931 8932 function Static_Component_Size (Comp : Entity_Id) return Boolean; 8933 -- When compiling under the Ravenscar profile, private components must 8934 -- have a static size, or else a protected object will require heap 8935 -- allocation, violating the corresponding restriction. It is preferable 8936 -- to make this check here, because it provides a better error message 8937 -- than the back-end, which refers to the object as a whole. 8938 8939 procedure Register_Handler; 8940 -- For a protected operation that is an interrupt handler, add the 8941 -- freeze action that will register it as such. 8942 8943 -------------------- 8944 -- Check_Inlining -- 8945 -------------------- 8946 8947 procedure Check_Inlining (Subp : Entity_Id) is 8948 begin 8949 if Is_Inlined (Subp) then 8950 Set_Is_Inlined (Protected_Body_Subprogram (Subp)); 8951 Set_Is_Inlined (Subp, False); 8952 end if; 8953 end Check_Inlining; 8954 8955 --------------------------- 8956 -- Static_Component_Size -- 8957 --------------------------- 8958 8959 function Static_Component_Size (Comp : Entity_Id) return Boolean is 8960 Typ : constant Entity_Id := Etype (Comp); 8961 C : Entity_Id; 8962 8963 begin 8964 if Is_Scalar_Type (Typ) then 8965 return True; 8966 8967 elsif Is_Array_Type (Typ) then 8968 return Compile_Time_Known_Bounds (Typ); 8969 8970 elsif Is_Record_Type (Typ) then 8971 C := First_Component (Typ); 8972 while Present (C) loop 8973 if not Static_Component_Size (C) then 8974 return False; 8975 end if; 8976 8977 Next_Component (C); 8978 end loop; 8979 8980 return True; 8981 8982 -- Any other type will be checked by the back-end 8983 8984 else 8985 return True; 8986 end if; 8987 end Static_Component_Size; 8988 8989 ------------------------------ 8990 -- Expand_Entry_Declaration -- 8991 ------------------------------ 8992 8993 procedure Expand_Entry_Declaration (Decl : Node_Id) is 8994 Ent_Id : constant Entity_Id := Defining_Entity (Decl); 8995 Bar_Id : Entity_Id; 8996 Bod_Id : Entity_Id; 8997 Subp : Node_Id; 8998 8999 begin 9000 E_Count := E_Count + 1; 9001 9002 -- Create the protected body subprogram 9003 9004 Bod_Id := 9005 Make_Defining_Identifier (Loc, 9006 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E')); 9007 Set_Protected_Body_Subprogram (Ent_Id, Bod_Id); 9008 9009 Subp := 9010 Make_Subprogram_Declaration (Loc, 9011 Specification => 9012 Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id)); 9013 9014 Insert_After (Current_Node, Subp); 9015 Current_Node := Subp; 9016 9017 Analyze (Subp); 9018 9019 -- Build a wrapper procedure to handle contract cases, preconditions, 9020 -- and postconditions. 9021 9022 Build_Contract_Wrapper (Ent_Id, N); 9023 9024 -- Create the barrier function 9025 9026 Bar_Id := 9027 Make_Defining_Identifier (Loc, 9028 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B')); 9029 Set_Barrier_Function (Ent_Id, Bar_Id); 9030 9031 Subp := 9032 Make_Subprogram_Declaration (Loc, 9033 Specification => 9034 Build_Barrier_Function_Specification (Loc, Bar_Id)); 9035 Set_Is_Entry_Barrier_Function (Subp); 9036 9037 Insert_After (Current_Node, Subp); 9038 Current_Node := Subp; 9039 9040 Analyze (Subp); 9041 9042 Set_Protected_Body_Subprogram (Bar_Id, Bar_Id); 9043 Set_Scope (Bar_Id, Scope (Ent_Id)); 9044 9045 -- Collect pointers to the protected subprogram and the barrier 9046 -- of the current entry, for insertion into Entry_Bodies_Array. 9047 9048 Append_To (Expressions (Entries_Aggr), 9049 Make_Aggregate (Loc, 9050 Expressions => New_List ( 9051 Make_Attribute_Reference (Loc, 9052 Prefix => New_Occurrence_Of (Bar_Id, Loc), 9053 Attribute_Name => Name_Unrestricted_Access), 9054 Make_Attribute_Reference (Loc, 9055 Prefix => New_Occurrence_Of (Bod_Id, Loc), 9056 Attribute_Name => Name_Unrestricted_Access)))); 9057 end Expand_Entry_Declaration; 9058 9059 ---------------------- 9060 -- Register_Handler -- 9061 ---------------------- 9062 9063 procedure Register_Handler is 9064 9065 -- All semantic checks already done in Sem_Prag 9066 9067 Prot_Proc : constant Entity_Id := 9068 Defining_Unit_Name (Specification (Current_Node)); 9069 9070 Proc_Address : constant Node_Id := 9071 Make_Attribute_Reference (Loc, 9072 Prefix => 9073 New_Occurrence_Of (Prot_Proc, Loc), 9074 Attribute_Name => Name_Address); 9075 9076 RTS_Call : constant Entity_Id := 9077 Make_Procedure_Call_Statement (Loc, 9078 Name => 9079 New_Occurrence_Of 9080 (RTE (RE_Register_Interrupt_Handler), Loc), 9081 Parameter_Associations => New_List (Proc_Address)); 9082 begin 9083 Append_Freeze_Action (Prot_Proc, RTS_Call); 9084 end Register_Handler; 9085 9086 -- Local variables 9087 9088 Body_Arr : Node_Id; 9089 Body_Id : Entity_Id; 9090 Cdecls : List_Id; 9091 Comp : Node_Id; 9092 Expr : Node_Id; 9093 New_Priv : Node_Id; 9094 Obj_Def : Node_Id; 9095 Object_Comp : Node_Id; 9096 Priv : Node_Id; 9097 Rec_Decl : Node_Id; 9098 Sub : Node_Id; 9099 9100 -- Start of processing for Expand_N_Protected_Type_Declaration 9101 9102 begin 9103 if Present (Corresponding_Record_Type (Prot_Typ)) then 9104 return; 9105 else 9106 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); 9107 end if; 9108 9109 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); 9110 9111 Qualify_Entity_Names (N); 9112 9113 -- If the type has discriminants, their occurrences in the declaration 9114 -- have been replaced by the corresponding discriminals. For components 9115 -- that are constrained by discriminants, their homologues in the 9116 -- corresponding record type must refer to the discriminants of that 9117 -- record, so we must apply a new renaming to subtypes_indications: 9118 9119 -- protected discriminant => discriminal => record discriminant 9120 9121 -- This replacement is not applied to default expressions, for which 9122 -- the discriminal is correct. 9123 9124 if Has_Discriminants (Prot_Typ) then 9125 declare 9126 Disc : Entity_Id; 9127 Decl : Node_Id; 9128 9129 begin 9130 Disc := First_Discriminant (Prot_Typ); 9131 Decl := First (Discriminant_Specifications (Rec_Decl)); 9132 while Present (Disc) loop 9133 Append_Elmt (Discriminal (Disc), Discr_Map); 9134 Append_Elmt (Defining_Identifier (Decl), Discr_Map); 9135 Next_Discriminant (Disc); 9136 Next (Decl); 9137 end loop; 9138 end; 9139 end if; 9140 9141 -- Fill in the component declarations 9142 9143 -- Add components for entry families. For each entry family, create an 9144 -- anonymous type declaration with the same size, and analyze the type. 9145 9146 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); 9147 9148 pragma Assert (Present (Pdef)); 9149 9150 Insert_After (Current_Node, Rec_Decl); 9151 Current_Node := Rec_Decl; 9152 9153 -- Add private field components 9154 9155 if Present (Private_Declarations (Pdef)) then 9156 Priv := First (Private_Declarations (Pdef)); 9157 while Present (Priv) loop 9158 if Nkind (Priv) = N_Component_Declaration then 9159 if not Static_Component_Size (Defining_Identifier (Priv)) then 9160 9161 -- When compiling for a restricted profile, the private 9162 -- components must have a static size. If not, this is an 9163 -- error for a single protected declaration, and rates a 9164 -- warning on a protected type declaration. 9165 9166 if not Comes_From_Source (Prot_Typ) then 9167 9168 -- It's ok to be checking this restriction at expansion 9169 -- time, because this is only for the restricted profile, 9170 -- which is not subject to strict RM conformance, so it 9171 -- is OK to miss this check in -gnatc mode. 9172 9173 Check_Restriction (No_Implicit_Heap_Allocations, Priv); 9174 Check_Restriction 9175 (No_Implicit_Protected_Object_Allocations, Priv); 9176 9177 elsif Restriction_Active (No_Implicit_Heap_Allocations) then 9178 if not Discriminated_Size (Defining_Identifier (Priv)) 9179 then 9180 -- Any object of the type will be non-static 9181 9182 Error_Msg_N ("component has non-static size??", Priv); 9183 Error_Msg_NE 9184 ("\creation of protected object of type& will " 9185 & "violate restriction " 9186 & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ); 9187 else 9188 -- Object will be non-static if discriminants are 9189 9190 Error_Msg_NE 9191 ("creation of protected object of type& with " 9192 & "non-static discriminants will violate " 9193 & "restriction No_Implicit_Heap_Allocations??", 9194 Priv, Prot_Typ); 9195 end if; 9196 9197 -- Likewise for No_Implicit_Protected_Object_Allocations 9198 9199 elsif Restriction_Active 9200 (No_Implicit_Protected_Object_Allocations) 9201 then 9202 if not Discriminated_Size (Defining_Identifier (Priv)) 9203 then 9204 -- Any object of the type will be non-static 9205 9206 Error_Msg_N ("component has non-static size??", Priv); 9207 Error_Msg_NE 9208 ("\creation of protected object of type& will " 9209 & "violate restriction " 9210 & "No_Implicit_Protected_Object_Allocations??", 9211 Priv, Prot_Typ); 9212 else 9213 -- Object will be non-static if discriminants are 9214 9215 Error_Msg_NE 9216 ("creation of protected object of type& with " 9217 & "non-static discriminants will violate " 9218 & "restriction " 9219 & "No_Implicit_Protected_Object_Allocations??", 9220 Priv, Prot_Typ); 9221 end if; 9222 end if; 9223 end if; 9224 9225 -- The component definition consists of a subtype indication, 9226 -- or (in Ada 2005) an access definition. Make a copy of the 9227 -- proper definition. 9228 9229 declare 9230 Old_Comp : constant Node_Id := Component_Definition (Priv); 9231 Oent : constant Entity_Id := Defining_Identifier (Priv); 9232 Nent : constant Entity_Id := 9233 Make_Defining_Identifier (Sloc (Oent), 9234 Chars => Chars (Oent)); 9235 New_Comp : Node_Id; 9236 9237 begin 9238 if Present (Subtype_Indication (Old_Comp)) then 9239 New_Comp := 9240 Make_Component_Definition (Sloc (Oent), 9241 Aliased_Present => False, 9242 Subtype_Indication => 9243 New_Copy_Tree 9244 (Subtype_Indication (Old_Comp), Discr_Map)); 9245 else 9246 New_Comp := 9247 Make_Component_Definition (Sloc (Oent), 9248 Aliased_Present => False, 9249 Access_Definition => 9250 New_Copy_Tree 9251 (Access_Definition (Old_Comp), Discr_Map)); 9252 end if; 9253 9254 New_Priv := 9255 Make_Component_Declaration (Loc, 9256 Defining_Identifier => Nent, 9257 Component_Definition => New_Comp, 9258 Expression => Expression (Priv)); 9259 9260 Set_Has_Per_Object_Constraint (Nent, 9261 Has_Per_Object_Constraint (Oent)); 9262 9263 Append_To (Cdecls, New_Priv); 9264 end; 9265 9266 elsif Nkind (Priv) = N_Subprogram_Declaration then 9267 9268 -- Make the unprotected version of the subprogram available 9269 -- for expansion of intra object calls. There is need for 9270 -- a protected version only if the subprogram is an interrupt 9271 -- handler, otherwise this operation can only be called from 9272 -- within the body. 9273 9274 Sub := 9275 Make_Subprogram_Declaration (Loc, 9276 Specification => 9277 Build_Protected_Sub_Specification 9278 (Priv, Prot_Typ, Unprotected_Mode)); 9279 9280 Insert_After (Current_Node, Sub); 9281 Analyze (Sub); 9282 9283 Set_Protected_Body_Subprogram 9284 (Defining_Unit_Name (Specification (Priv)), 9285 Defining_Unit_Name (Specification (Sub))); 9286 Check_Inlining (Defining_Unit_Name (Specification (Priv))); 9287 Current_Node := Sub; 9288 9289 Sub := 9290 Make_Subprogram_Declaration (Loc, 9291 Specification => 9292 Build_Protected_Sub_Specification 9293 (Priv, Prot_Typ, Protected_Mode)); 9294 9295 Insert_After (Current_Node, Sub); 9296 Analyze (Sub); 9297 Current_Node := Sub; 9298 9299 if Is_Interrupt_Handler 9300 (Defining_Unit_Name (Specification (Priv))) 9301 then 9302 if not Restricted_Profile then 9303 Register_Handler; 9304 end if; 9305 end if; 9306 end if; 9307 9308 Next (Priv); 9309 end loop; 9310 end if; 9311 9312 -- Except for the lock-free implementation, append the _Object field 9313 -- with the right type to the component list. We need to compute the 9314 -- number of entries, and in some cases the number of Attach_Handler 9315 -- pragmas. 9316 9317 if not Lock_Free_Active then 9318 declare 9319 Entry_Count_Expr : constant Node_Id := 9320 Build_Entry_Count_Expression 9321 (Prot_Typ, Cdecls, Loc); 9322 Num_Attach_Handler : Nat := 0; 9323 Protection_Subtype : Node_Id; 9324 Ritem : Node_Id; 9325 9326 begin 9327 if Has_Attach_Handler (Prot_Typ) then 9328 Ritem := First_Rep_Item (Prot_Typ); 9329 while Present (Ritem) loop 9330 if Nkind (Ritem) = N_Pragma 9331 and then Pragma_Name (Ritem) = Name_Attach_Handler 9332 then 9333 Num_Attach_Handler := Num_Attach_Handler + 1; 9334 end if; 9335 9336 Next_Rep_Item (Ritem); 9337 end loop; 9338 end if; 9339 9340 -- Determine the proper protection type. There are two special 9341 -- cases: 1) when the protected type has dynamic interrupt 9342 -- handlers, and 2) when it has static handlers and we use a 9343 -- restricted profile. 9344 9345 if Has_Attach_Handler (Prot_Typ) 9346 and then not Restricted_Profile 9347 then 9348 Protection_Subtype := 9349 Make_Subtype_Indication (Loc, 9350 Subtype_Mark => 9351 New_Occurrence_Of 9352 (RTE (RE_Static_Interrupt_Protection), Loc), 9353 Constraint => 9354 Make_Index_Or_Discriminant_Constraint (Loc, 9355 Constraints => New_List ( 9356 Entry_Count_Expr, 9357 Make_Integer_Literal (Loc, Num_Attach_Handler)))); 9358 9359 elsif Has_Interrupt_Handler (Prot_Typ) 9360 and then not Restriction_Active (No_Dynamic_Attachment) 9361 then 9362 Protection_Subtype := 9363 Make_Subtype_Indication (Loc, 9364 Subtype_Mark => 9365 New_Occurrence_Of 9366 (RTE (RE_Dynamic_Interrupt_Protection), Loc), 9367 Constraint => 9368 Make_Index_Or_Discriminant_Constraint (Loc, 9369 Constraints => New_List (Entry_Count_Expr))); 9370 9371 else 9372 case Corresponding_Runtime_Package (Prot_Typ) is 9373 when System_Tasking_Protected_Objects_Entries => 9374 Protection_Subtype := 9375 Make_Subtype_Indication (Loc, 9376 Subtype_Mark => 9377 New_Occurrence_Of 9378 (RTE (RE_Protection_Entries), Loc), 9379 Constraint => 9380 Make_Index_Or_Discriminant_Constraint (Loc, 9381 Constraints => New_List (Entry_Count_Expr))); 9382 9383 when System_Tasking_Protected_Objects_Single_Entry => 9384 Protection_Subtype := 9385 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc); 9386 9387 when System_Tasking_Protected_Objects => 9388 Protection_Subtype := 9389 New_Occurrence_Of (RTE (RE_Protection), Loc); 9390 9391 when others => 9392 raise Program_Error; 9393 end case; 9394 end if; 9395 9396 Object_Comp := 9397 Make_Component_Declaration (Loc, 9398 Defining_Identifier => 9399 Make_Defining_Identifier (Loc, Name_uObject), 9400 Component_Definition => 9401 Make_Component_Definition (Loc, 9402 Aliased_Present => True, 9403 Subtype_Indication => Protection_Subtype)); 9404 end; 9405 9406 -- Put the _Object component after the private component so that it 9407 -- be finalized early as required by 9.4 (20) 9408 9409 Append_To (Cdecls, Object_Comp); 9410 end if; 9411 9412 -- Analyze the record declaration immediately after construction, 9413 -- because the initialization procedure is needed for single object 9414 -- declarations before the next entity is analyzed (the freeze call 9415 -- that generates this initialization procedure is found below). 9416 9417 Analyze (Rec_Decl, Suppress => All_Checks); 9418 9419 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before 9420 -- the corresponding record is frozen. If any wrappers are generated, 9421 -- Current_Node is updated accordingly. 9422 9423 if Ada_Version >= Ada_2005 then 9424 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node); 9425 end if; 9426 9427 -- Collect pointers to entry bodies and their barriers, to be placed 9428 -- in the Entry_Bodies_Array for the type. For each entry/family we 9429 -- add an expression to the aggregate which is the initial value of 9430 -- this array. The array is declared after all protected subprograms. 9431 9432 if Has_Entries (Prot_Typ) then 9433 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); 9434 else 9435 Entries_Aggr := Empty; 9436 end if; 9437 9438 -- Build two new procedure specifications for each protected subprogram; 9439 -- one to call from outside the object and one to call from inside. 9440 -- Build a barrier function and an entry body action procedure 9441 -- specification for each protected entry. Initialize the entry body 9442 -- array. If subprogram is flagged as eliminated, do not generate any 9443 -- internal operations. 9444 9445 E_Count := 0; 9446 Comp := First (Visible_Declarations (Pdef)); 9447 while Present (Comp) loop 9448 if Nkind (Comp) = N_Subprogram_Declaration then 9449 Sub := 9450 Make_Subprogram_Declaration (Loc, 9451 Specification => 9452 Build_Protected_Sub_Specification 9453 (Comp, Prot_Typ, Unprotected_Mode)); 9454 9455 Insert_After (Current_Node, Sub); 9456 Analyze (Sub); 9457 9458 Set_Protected_Body_Subprogram 9459 (Defining_Unit_Name (Specification (Comp)), 9460 Defining_Unit_Name (Specification (Sub))); 9461 Check_Inlining (Defining_Unit_Name (Specification (Comp))); 9462 9463 -- Make the protected version of the subprogram available for 9464 -- expansion of external calls. 9465 9466 Current_Node := Sub; 9467 9468 Sub := 9469 Make_Subprogram_Declaration (Loc, 9470 Specification => 9471 Build_Protected_Sub_Specification 9472 (Comp, Prot_Typ, Protected_Mode)); 9473 9474 Insert_After (Current_Node, Sub); 9475 Analyze (Sub); 9476 9477 Current_Node := Sub; 9478 9479 -- Generate an overriding primitive operation specification for 9480 -- this subprogram if the protected type implements an interface 9481 -- and Build_Wrapper_Spec did not generate its wrapper. 9482 9483 if Ada_Version >= Ada_2005 9484 and then 9485 Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) 9486 then 9487 declare 9488 Found : Boolean := False; 9489 Prim_Elmt : Elmt_Id; 9490 Prim_Op : Node_Id; 9491 9492 begin 9493 Prim_Elmt := 9494 First_Elmt 9495 (Primitive_Operations 9496 (Corresponding_Record_Type (Prot_Typ))); 9497 9498 while Present (Prim_Elmt) loop 9499 Prim_Op := Node (Prim_Elmt); 9500 9501 if Is_Primitive_Wrapper (Prim_Op) 9502 and then Wrapped_Entity (Prim_Op) = 9503 Defining_Entity (Specification (Comp)) 9504 then 9505 Found := True; 9506 exit; 9507 end if; 9508 9509 Next_Elmt (Prim_Elmt); 9510 end loop; 9511 9512 if not Found then 9513 Sub := 9514 Make_Subprogram_Declaration (Loc, 9515 Specification => 9516 Build_Protected_Sub_Specification 9517 (Comp, Prot_Typ, Dispatching_Mode)); 9518 9519 Insert_After (Current_Node, Sub); 9520 Analyze (Sub); 9521 9522 Current_Node := Sub; 9523 end if; 9524 end; 9525 end if; 9526 9527 -- If a pragma Interrupt_Handler applies, build and add a call to 9528 -- Register_Interrupt_Handler to the freezing actions of the 9529 -- protected version (Current_Node) of the subprogram: 9530 9531 -- system.interrupts.register_interrupt_handler 9532 -- (prot_procP'address); 9533 9534 if not Restricted_Profile 9535 and then Is_Interrupt_Handler 9536 (Defining_Unit_Name (Specification (Comp))) 9537 then 9538 Register_Handler; 9539 end if; 9540 9541 elsif Nkind (Comp) = N_Entry_Declaration then 9542 Expand_Entry_Declaration (Comp); 9543 end if; 9544 9545 Next (Comp); 9546 end loop; 9547 9548 -- If there are some private entry declarations, expand it as if they 9549 -- were visible entries. 9550 9551 if Present (Private_Declarations (Pdef)) then 9552 Comp := First (Private_Declarations (Pdef)); 9553 while Present (Comp) loop 9554 if Nkind (Comp) = N_Entry_Declaration then 9555 Expand_Entry_Declaration (Comp); 9556 end if; 9557 9558 Next (Comp); 9559 end loop; 9560 end if; 9561 9562 -- Create the declaration of an array object which contains the values 9563 -- of aspect/pragma Max_Queue_Length for all entries of the protected 9564 -- type. This object is later passed to the appropriate protected object 9565 -- initialization routine. 9566 9567 if Has_Entries (Prot_Typ) 9568 and then Corresponding_Runtime_Package (Prot_Typ) = 9569 System_Tasking_Protected_Objects_Entries 9570 then 9571 declare 9572 Count : Int; 9573 Item : Entity_Id; 9574 Max_Vals : Node_Id; 9575 Maxes : List_Id; 9576 Maxes_Id : Entity_Id; 9577 Need_Array : Boolean := False; 9578 9579 begin 9580 -- First check if there is any Max_Queue_Length pragma 9581 9582 Item := First_Entity (Prot_Typ); 9583 while Present (Item) loop 9584 if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then 9585 Need_Array := True; 9586 exit; 9587 end if; 9588 9589 Next_Entity (Item); 9590 end loop; 9591 9592 -- Gather the Max_Queue_Length values of all entries in a list. A 9593 -- value of zero indicates that the entry has no limitation on its 9594 -- queue length. 9595 9596 if Need_Array then 9597 Count := 0; 9598 Item := First_Entity (Prot_Typ); 9599 Maxes := New_List; 9600 while Present (Item) loop 9601 if Is_Entry (Item) then 9602 Count := Count + 1; 9603 Append_To (Maxes, 9604 Make_Integer_Literal 9605 (Loc, Get_Max_Queue_Length (Item))); 9606 end if; 9607 9608 Next_Entity (Item); 9609 end loop; 9610 9611 -- Create the declaration of the array object. Generate: 9612 9613 -- Maxes_Id : aliased constant 9614 -- Protected_Entry_Queue_Max_Array 9615 -- (1 .. Count) := (..., ...); 9616 9617 Maxes_Id := 9618 Make_Defining_Identifier (Loc, 9619 Chars => New_External_Name (Chars (Prot_Typ), 'B')); 9620 9621 Max_Vals := 9622 Make_Object_Declaration (Loc, 9623 Defining_Identifier => Maxes_Id, 9624 Aliased_Present => True, 9625 Constant_Present => True, 9626 Object_Definition => 9627 Make_Subtype_Indication (Loc, 9628 Subtype_Mark => 9629 New_Occurrence_Of 9630 (RTE (RE_Protected_Entry_Queue_Max_Array), Loc), 9631 Constraint => 9632 Make_Index_Or_Discriminant_Constraint (Loc, 9633 Constraints => New_List ( 9634 Make_Range (Loc, 9635 Make_Integer_Literal (Loc, 1), 9636 Make_Integer_Literal (Loc, Count))))), 9637 Expression => Make_Aggregate (Loc, Maxes)); 9638 9639 -- A pointer to this array will be placed in the corresponding 9640 -- record by its initialization procedure so this needs to be 9641 -- analyzed here. 9642 9643 Insert_After (Current_Node, Max_Vals); 9644 Current_Node := Max_Vals; 9645 Analyze (Max_Vals); 9646 9647 Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxes_Id); 9648 end if; 9649 end; 9650 end if; 9651 9652 -- Emit declaration for Entry_Bodies_Array, now that the addresses of 9653 -- all protected subprograms have been collected. 9654 9655 if Has_Entries (Prot_Typ) then 9656 Body_Id := 9657 Make_Defining_Identifier (Sloc (Prot_Typ), 9658 Chars => New_External_Name (Chars (Prot_Typ), 'A')); 9659 9660 case Corresponding_Runtime_Package (Prot_Typ) is 9661 when System_Tasking_Protected_Objects_Entries => 9662 Expr := Entries_Aggr; 9663 Obj_Def := 9664 Make_Subtype_Indication (Loc, 9665 Subtype_Mark => 9666 New_Occurrence_Of 9667 (RTE (RE_Protected_Entry_Body_Array), Loc), 9668 Constraint => 9669 Make_Index_Or_Discriminant_Constraint (Loc, 9670 Constraints => New_List ( 9671 Make_Range (Loc, 9672 Make_Integer_Literal (Loc, 1), 9673 Make_Integer_Literal (Loc, E_Count))))); 9674 9675 when System_Tasking_Protected_Objects_Single_Entry => 9676 Expr := Remove_Head (Expressions (Entries_Aggr)); 9677 Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc); 9678 9679 when others => 9680 raise Program_Error; 9681 end case; 9682 9683 Body_Arr := 9684 Make_Object_Declaration (Loc, 9685 Defining_Identifier => Body_Id, 9686 Aliased_Present => True, 9687 Constant_Present => True, 9688 Object_Definition => Obj_Def, 9689 Expression => Expr); 9690 9691 -- A pointer to this array will be placed in the corresponding record 9692 -- by its initialization procedure so this needs to be analyzed here. 9693 9694 Insert_After (Current_Node, Body_Arr); 9695 Current_Node := Body_Arr; 9696 Analyze (Body_Arr); 9697 9698 Set_Entry_Bodies_Array (Prot_Typ, Body_Id); 9699 9700 -- Finally, build the function that maps an entry index into the 9701 -- corresponding body. A pointer to this function is placed in each 9702 -- object of the type. Except for a ravenscar-like profile (no abort, 9703 -- no entry queue, 1 entry) 9704 9705 if Corresponding_Runtime_Package (Prot_Typ) = 9706 System_Tasking_Protected_Objects_Entries 9707 then 9708 Sub := 9709 Make_Subprogram_Declaration (Loc, 9710 Specification => Build_Find_Body_Index_Spec (Prot_Typ)); 9711 9712 Insert_After (Current_Node, Sub); 9713 Analyze (Sub); 9714 end if; 9715 end if; 9716 end Expand_N_Protected_Type_Declaration; 9717 9718 -------------------------------- 9719 -- Expand_N_Requeue_Statement -- 9720 -------------------------------- 9721 9722 -- A nondispatching requeue statement is expanded into one of four GNARLI 9723 -- operations, depending on the source and destination (task or protected 9724 -- object). A dispatching requeue statement is expanded into a call to the 9725 -- predefined primitive _Disp_Requeue. In addition, code is generated to 9726 -- jump around the remainder of processing for the original entry and, if 9727 -- the destination is (different) protected object, to attempt to service 9728 -- it. The following illustrates the various cases: 9729 9730 -- procedure entE 9731 -- (O : System.Address; 9732 -- P : System.Address; 9733 -- E : Protected_Entry_Index) 9734 -- is 9735 -- <discriminant renamings> 9736 -- <private object renamings> 9737 -- type poVP is access poV; 9738 -- _object : ptVP := ptVP!(O); 9739 9740 -- begin 9741 -- begin 9742 -- <start of statement sequence for entry> 9743 9744 -- -- Requeue from one protected entry body to another protected 9745 -- -- entry. 9746 9747 -- Requeue_Protected_Entry ( 9748 -- _object._object'Access, 9749 -- new._object'Access, 9750 -- E, 9751 -- Abort_Present); 9752 -- return; 9753 9754 -- <some more of the statement sequence for entry> 9755 9756 -- -- Requeue from an entry body to a task entry 9757 9758 -- Requeue_Protected_To_Task_Entry ( 9759 -- New._task_id, 9760 -- E, 9761 -- Abort_Present); 9762 -- return; 9763 9764 -- <rest of statement sequence for entry> 9765 -- Complete_Entry_Body (_object._object); 9766 9767 -- exception 9768 -- when all others => 9769 -- Exceptional_Complete_Entry_Body ( 9770 -- _object._object, Get_GNAT_Exception); 9771 -- end; 9772 -- end entE; 9773 9774 -- Requeue of a task entry call to a task entry 9775 9776 -- Accept_Call (E, Ann); 9777 -- <start of statement sequence for accept statement> 9778 -- Requeue_Task_Entry (New._task_id, E, Abort_Present); 9779 -- goto Lnn; 9780 -- <rest of statement sequence for accept statement> 9781 -- <<Lnn>> 9782 -- Complete_Rendezvous; 9783 9784 -- exception 9785 -- when all others => 9786 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9787 9788 -- Requeue of a task entry call to a protected entry 9789 9790 -- Accept_Call (E, Ann); 9791 -- <start of statement sequence for accept statement> 9792 -- Requeue_Task_To_Protected_Entry ( 9793 -- new._object'Access, 9794 -- E, 9795 -- Abort_Present); 9796 -- newS (new, Pnn); 9797 -- goto Lnn; 9798 -- <rest of statement sequence for accept statement> 9799 -- <<Lnn>> 9800 -- Complete_Rendezvous; 9801 9802 -- exception 9803 -- when all others => 9804 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9805 9806 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9807 -- marked by pragma Implemented (XXX, By_Entry). 9808 9809 -- The requeue is inside a protected entry: 9810 9811 -- procedure entE 9812 -- (O : System.Address; 9813 -- P : System.Address; 9814 -- E : Protected_Entry_Index) 9815 -- is 9816 -- <discriminant renamings> 9817 -- <private object renamings> 9818 -- type poVP is access poV; 9819 -- _object : ptVP := ptVP!(O); 9820 9821 -- begin 9822 -- begin 9823 -- <start of statement sequence for entry> 9824 9825 -- _Disp_Requeue 9826 -- (<interface class-wide object>, 9827 -- True, 9828 -- _object'Address, 9829 -- Ada.Tags.Get_Offset_Index 9830 -- (Tag (_object), 9831 -- <interface dispatch table index of target entry>), 9832 -- Abort_Present); 9833 -- return; 9834 9835 -- <rest of statement sequence for entry> 9836 -- Complete_Entry_Body (_object._object); 9837 9838 -- exception 9839 -- when all others => 9840 -- Exceptional_Complete_Entry_Body ( 9841 -- _object._object, Get_GNAT_Exception); 9842 -- end; 9843 -- end entE; 9844 9845 -- The requeue is inside a task entry: 9846 9847 -- Accept_Call (E, Ann); 9848 -- <start of statement sequence for accept statement> 9849 -- _Disp_Requeue 9850 -- (<interface class-wide object>, 9851 -- False, 9852 -- null, 9853 -- Ada.Tags.Get_Offset_Index 9854 -- (Tag (_object), 9855 -- <interface dispatch table index of target entrt>), 9856 -- Abort_Present); 9857 -- newS (new, Pnn); 9858 -- goto Lnn; 9859 -- <rest of statement sequence for accept statement> 9860 -- <<Lnn>> 9861 -- Complete_Rendezvous; 9862 9863 -- exception 9864 -- when all others => 9865 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9866 9867 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9868 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue 9869 -- statement is replaced by a dispatching call with actual parameters taken 9870 -- from the inner-most accept statement or entry body. 9871 9872 -- Target.Primitive (Param1, ..., ParamN); 9873 9874 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9875 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked 9876 -- at all. 9877 9878 -- declare 9879 -- S : constant Offset_Index := 9880 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename)); 9881 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S); 9882 9883 -- begin 9884 -- if C = POK_Protected_Entry 9885 -- or else C = POK_Task_Entry 9886 -- then 9887 -- <statements for dispatching requeue> 9888 9889 -- elsif C = POK_Protected_Procedure then 9890 -- <dispatching call equivalent> 9891 9892 -- else 9893 -- raise Program_Error; 9894 -- end if; 9895 -- end; 9896 9897 procedure Expand_N_Requeue_Statement (N : Node_Id) is 9898 Loc : constant Source_Ptr := Sloc (N); 9899 Conc_Typ : Entity_Id; 9900 Concval : Node_Id; 9901 Ename : Node_Id; 9902 Index : Node_Id; 9903 Old_Typ : Entity_Id; 9904 9905 function Build_Dispatching_Call_Equivalent return Node_Id; 9906 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9907 -- the form Concval.Ename. It is statically known that Ename is allowed 9908 -- to be implemented by a protected procedure. Create a dispatching call 9909 -- equivalent of Concval.Ename taking the actual parameters from the 9910 -- inner-most accept statement or entry body. 9911 9912 function Build_Dispatching_Requeue return Node_Id; 9913 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9914 -- the form Concval.Ename. It is statically known that Ename is allowed 9915 -- to be implemented by a protected or a task entry. Create a call to 9916 -- primitive _Disp_Requeue which handles the low-level actions. 9917 9918 function Build_Dispatching_Requeue_To_Any return Node_Id; 9919 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9920 -- the form Concval.Ename. Ename is either marked by pragma Implemented 9921 -- (XXX, By_Any | Optional) or not marked at all. Create a block which 9922 -- determines at runtime whether Ename denotes an entry or a procedure 9923 -- and perform the appropriate kind of dispatching select. 9924 9925 function Build_Normal_Requeue return Node_Id; 9926 -- N denotes a nondispatching requeue statement to either a task or a 9927 -- protected entry. Build the appropriate runtime call to perform the 9928 -- action. 9929 9930 function Build_Skip_Statement (Search : Node_Id) return Node_Id; 9931 -- For a protected entry, create a return statement to skip the rest of 9932 -- the entry body. Otherwise, create a goto statement to skip the rest 9933 -- of a task accept statement. The lookup for the enclosing entry body 9934 -- or accept statement starts from Search. 9935 9936 --------------------------------------- 9937 -- Build_Dispatching_Call_Equivalent -- 9938 --------------------------------------- 9939 9940 function Build_Dispatching_Call_Equivalent return Node_Id is 9941 Call_Ent : constant Entity_Id := Entity (Ename); 9942 Obj : constant Node_Id := Original_Node (Concval); 9943 Acc_Ent : Node_Id; 9944 Actuals : List_Id; 9945 Formal : Node_Id; 9946 Formals : List_Id; 9947 9948 begin 9949 -- Climb the parent chain looking for the inner-most entry body or 9950 -- accept statement. 9951 9952 Acc_Ent := N; 9953 while Present (Acc_Ent) 9954 and then not Nkind_In (Acc_Ent, N_Accept_Statement, 9955 N_Entry_Body) 9956 loop 9957 Acc_Ent := Parent (Acc_Ent); 9958 end loop; 9959 9960 -- A requeue statement should be housed inside an entry body or an 9961 -- accept statement at some level. If this is not the case, then the 9962 -- tree is malformed. 9963 9964 pragma Assert (Present (Acc_Ent)); 9965 9966 -- Recover the list of formal parameters 9967 9968 if Nkind (Acc_Ent) = N_Entry_Body then 9969 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent); 9970 end if; 9971 9972 Formals := Parameter_Specifications (Acc_Ent); 9973 9974 -- Create the actual parameters for the dispatching call. These are 9975 -- simply copies of the entry body or accept statement formals in the 9976 -- same order as they appear. 9977 9978 Actuals := No_List; 9979 9980 if Present (Formals) then 9981 Actuals := New_List; 9982 Formal := First (Formals); 9983 while Present (Formal) loop 9984 Append_To (Actuals, 9985 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 9986 Next (Formal); 9987 end loop; 9988 end if; 9989 9990 -- Generate: 9991 -- Obj.Call_Ent (Actuals); 9992 9993 return 9994 Make_Procedure_Call_Statement (Loc, 9995 Name => 9996 Make_Selected_Component (Loc, 9997 Prefix => Make_Identifier (Loc, Chars (Obj)), 9998 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))), 9999 10000 Parameter_Associations => Actuals); 10001 end Build_Dispatching_Call_Equivalent; 10002 10003 ------------------------------- 10004 -- Build_Dispatching_Requeue -- 10005 ------------------------------- 10006 10007 function Build_Dispatching_Requeue return Node_Id is 10008 Params : constant List_Id := New_List; 10009 10010 begin 10011 -- Process the "with abort" parameter 10012 10013 Prepend_To (Params, 10014 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10015 10016 -- Process the entry wrapper's position in the primary dispatch 10017 -- table parameter. Generate: 10018 10019 -- Ada.Tags.Get_Entry_Index 10020 -- (T => To_Tag_Ptr (Obj'Address).all, 10021 -- Position => 10022 -- Ada.Tags.Get_Offset_Index 10023 -- (Ada.Tags.Tag (Concval), 10024 -- <interface dispatch table position of Ename>)); 10025 10026 -- Note that Obj'Address is recursively expanded into a call to 10027 -- Base_Address (Obj). 10028 10029 if Tagged_Type_Expansion then 10030 Prepend_To (Params, 10031 Make_Function_Call (Loc, 10032 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 10033 Parameter_Associations => New_List ( 10034 10035 Make_Explicit_Dereference (Loc, 10036 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 10037 Make_Attribute_Reference (Loc, 10038 Prefix => New_Copy_Tree (Concval), 10039 Attribute_Name => Name_Address))), 10040 10041 Make_Function_Call (Loc, 10042 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 10043 Parameter_Associations => New_List ( 10044 Unchecked_Convert_To (RTE (RE_Tag), Concval), 10045 Make_Integer_Literal (Loc, 10046 DT_Position (Entity (Ename)))))))); 10047 10048 -- VM targets 10049 10050 else 10051 Prepend_To (Params, 10052 Make_Function_Call (Loc, 10053 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 10054 Parameter_Associations => New_List ( 10055 10056 Make_Attribute_Reference (Loc, 10057 Prefix => Concval, 10058 Attribute_Name => Name_Tag), 10059 10060 Make_Function_Call (Loc, 10061 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 10062 10063 Parameter_Associations => New_List ( 10064 10065 -- Obj_Tag 10066 10067 Make_Attribute_Reference (Loc, 10068 Prefix => Concval, 10069 Attribute_Name => Name_Tag), 10070 10071 -- Tag_Typ 10072 10073 Make_Attribute_Reference (Loc, 10074 Prefix => New_Occurrence_Of (Etype (Concval), Loc), 10075 Attribute_Name => Name_Tag), 10076 10077 -- Position 10078 10079 Make_Integer_Literal (Loc, 10080 DT_Position (Entity (Ename)))))))); 10081 end if; 10082 10083 -- Specific actuals for protected to XXX requeue 10084 10085 if Is_Protected_Type (Old_Typ) then 10086 Prepend_To (Params, 10087 Make_Attribute_Reference (Loc, -- _object'Address 10088 Prefix => 10089 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10090 Attribute_Name => Name_Address)); 10091 10092 Prepend_To (Params, -- True 10093 New_Occurrence_Of (Standard_True, Loc)); 10094 10095 -- Specific actuals for task to XXX requeue 10096 10097 else 10098 pragma Assert (Is_Task_Type (Old_Typ)); 10099 10100 Prepend_To (Params, -- null 10101 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 10102 10103 Prepend_To (Params, -- False 10104 New_Occurrence_Of (Standard_False, Loc)); 10105 end if; 10106 10107 -- Add the object parameter 10108 10109 Prepend_To (Params, New_Copy_Tree (Concval)); 10110 10111 -- Generate: 10112 -- _Disp_Requeue (<Params>); 10113 10114 -- Find entity for Disp_Requeue operation, which belongs to 10115 -- the type and may not be directly visible. 10116 10117 declare 10118 Elmt : Elmt_Id; 10119 Op : Entity_Id; 10120 pragma Warnings (Off, Op); 10121 10122 begin 10123 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ))); 10124 while Present (Elmt) loop 10125 Op := Node (Elmt); 10126 exit when Chars (Op) = Name_uDisp_Requeue; 10127 Next_Elmt (Elmt); 10128 end loop; 10129 10130 return 10131 Make_Procedure_Call_Statement (Loc, 10132 Name => New_Occurrence_Of (Op, Loc), 10133 Parameter_Associations => Params); 10134 end; 10135 end Build_Dispatching_Requeue; 10136 10137 -------------------------------------- 10138 -- Build_Dispatching_Requeue_To_Any -- 10139 -------------------------------------- 10140 10141 function Build_Dispatching_Requeue_To_Any return Node_Id is 10142 Call_Ent : constant Entity_Id := Entity (Ename); 10143 Obj : constant Node_Id := Original_Node (Concval); 10144 Skip : constant Node_Id := Build_Skip_Statement (N); 10145 C : Entity_Id; 10146 Decls : List_Id; 10147 S : Entity_Id; 10148 Stmts : List_Id; 10149 10150 begin 10151 Decls := New_List; 10152 Stmts := New_List; 10153 10154 -- Dispatch table slot processing, generate: 10155 -- S : Integer; 10156 10157 S := Build_S (Loc, Decls); 10158 10159 -- Call kind processing, generate: 10160 -- C : Ada.Tags.Prim_Op_Kind; 10161 10162 C := Build_C (Loc, Decls); 10163 10164 -- Generate: 10165 -- S := Ada.Tags.Get_Offset_Index 10166 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent)); 10167 10168 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent)); 10169 10170 -- Generate: 10171 -- _Disp_Get_Prim_Op_Kind (Obj, S, C); 10172 10173 Append_To (Stmts, 10174 Make_Procedure_Call_Statement (Loc, 10175 Name => 10176 New_Occurrence_Of ( 10177 Find_Prim_Op (Etype (Etype (Obj)), 10178 Name_uDisp_Get_Prim_Op_Kind), 10179 Loc), 10180 Parameter_Associations => New_List ( 10181 New_Copy_Tree (Obj), 10182 New_Occurrence_Of (S, Loc), 10183 New_Occurrence_Of (C, Loc)))); 10184 10185 Append_To (Stmts, 10186 10187 -- if C = POK_Protected_Entry 10188 -- or else C = POK_Task_Entry 10189 -- then 10190 10191 Make_Implicit_If_Statement (N, 10192 Condition => 10193 Make_Op_Or (Loc, 10194 Left_Opnd => 10195 Make_Op_Eq (Loc, 10196 Left_Opnd => 10197 New_Occurrence_Of (C, Loc), 10198 Right_Opnd => 10199 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 10200 10201 Right_Opnd => 10202 Make_Op_Eq (Loc, 10203 Left_Opnd => 10204 New_Occurrence_Of (C, Loc), 10205 Right_Opnd => 10206 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 10207 10208 -- Dispatching requeue equivalent 10209 10210 Then_Statements => New_List ( 10211 Build_Dispatching_Requeue, 10212 Skip), 10213 10214 -- elsif C = POK_Protected_Procedure then 10215 10216 Elsif_Parts => New_List ( 10217 Make_Elsif_Part (Loc, 10218 Condition => 10219 Make_Op_Eq (Loc, 10220 Left_Opnd => 10221 New_Occurrence_Of (C, Loc), 10222 Right_Opnd => 10223 New_Occurrence_Of ( 10224 RTE (RE_POK_Protected_Procedure), Loc)), 10225 10226 -- Dispatching call equivalent 10227 10228 Then_Statements => New_List ( 10229 Build_Dispatching_Call_Equivalent))), 10230 10231 -- else 10232 -- raise Program_Error; 10233 -- end if; 10234 10235 Else_Statements => New_List ( 10236 Make_Raise_Program_Error (Loc, 10237 Reason => PE_Explicit_Raise)))); 10238 10239 -- Wrap everything into a block 10240 10241 return 10242 Make_Block_Statement (Loc, 10243 Declarations => Decls, 10244 Handled_Statement_Sequence => 10245 Make_Handled_Sequence_Of_Statements (Loc, 10246 Statements => Stmts)); 10247 end Build_Dispatching_Requeue_To_Any; 10248 10249 -------------------------- 10250 -- Build_Normal_Requeue -- 10251 -------------------------- 10252 10253 function Build_Normal_Requeue return Node_Id is 10254 Params : constant List_Id := New_List; 10255 Param : Node_Id; 10256 RT_Call : Node_Id; 10257 10258 begin 10259 -- Process the "with abort" parameter 10260 10261 Prepend_To (Params, 10262 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10263 10264 -- Add the index expression to the parameters. It is common among all 10265 -- four cases. 10266 10267 Prepend_To (Params, 10268 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ)); 10269 10270 if Is_Protected_Type (Old_Typ) then 10271 declare 10272 Self_Param : Node_Id; 10273 10274 begin 10275 Self_Param := 10276 Make_Attribute_Reference (Loc, 10277 Prefix => 10278 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10279 Attribute_Name => 10280 Name_Unchecked_Access); 10281 10282 -- Protected to protected requeue 10283 10284 if Is_Protected_Type (Conc_Typ) then 10285 RT_Call := 10286 New_Occurrence_Of ( 10287 RTE (RE_Requeue_Protected_Entry), Loc); 10288 10289 Param := 10290 Make_Attribute_Reference (Loc, 10291 Prefix => 10292 Concurrent_Ref (Concval), 10293 Attribute_Name => 10294 Name_Unchecked_Access); 10295 10296 -- Protected to task requeue 10297 10298 else pragma Assert (Is_Task_Type (Conc_Typ)); 10299 RT_Call := 10300 New_Occurrence_Of ( 10301 RTE (RE_Requeue_Protected_To_Task_Entry), Loc); 10302 10303 Param := Concurrent_Ref (Concval); 10304 end if; 10305 10306 Prepend_To (Params, Param); 10307 Prepend_To (Params, Self_Param); 10308 end; 10309 10310 else pragma Assert (Is_Task_Type (Old_Typ)); 10311 10312 -- Task to protected requeue 10313 10314 if Is_Protected_Type (Conc_Typ) then 10315 RT_Call := 10316 New_Occurrence_Of ( 10317 RTE (RE_Requeue_Task_To_Protected_Entry), Loc); 10318 10319 Param := 10320 Make_Attribute_Reference (Loc, 10321 Prefix => 10322 Concurrent_Ref (Concval), 10323 Attribute_Name => 10324 Name_Unchecked_Access); 10325 10326 -- Task to task requeue 10327 10328 else pragma Assert (Is_Task_Type (Conc_Typ)); 10329 RT_Call := 10330 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc); 10331 10332 Param := Concurrent_Ref (Concval); 10333 end if; 10334 10335 Prepend_To (Params, Param); 10336 end if; 10337 10338 return 10339 Make_Procedure_Call_Statement (Loc, 10340 Name => RT_Call, 10341 Parameter_Associations => Params); 10342 end Build_Normal_Requeue; 10343 10344 -------------------------- 10345 -- Build_Skip_Statement -- 10346 -------------------------- 10347 10348 function Build_Skip_Statement (Search : Node_Id) return Node_Id is 10349 Skip_Stmt : Node_Id; 10350 10351 begin 10352 -- Build a return statement to skip the rest of the entire body 10353 10354 if Is_Protected_Type (Old_Typ) then 10355 Skip_Stmt := Make_Simple_Return_Statement (Loc); 10356 10357 -- If the requeue is within a task, find the end label of the 10358 -- enclosing accept statement and create a goto statement to it. 10359 10360 else 10361 declare 10362 Acc : Node_Id; 10363 Label : Node_Id; 10364 10365 begin 10366 -- Climb the parent chain looking for the enclosing accept 10367 -- statement. 10368 10369 Acc := Parent (Search); 10370 while Present (Acc) 10371 and then Nkind (Acc) /= N_Accept_Statement 10372 loop 10373 Acc := Parent (Acc); 10374 end loop; 10375 10376 -- The last statement is the second label used for completing 10377 -- the rendezvous the usual way. The label we are looking for 10378 -- is right before it. 10379 10380 Label := 10381 Prev (Last (Statements (Handled_Statement_Sequence (Acc)))); 10382 10383 pragma Assert (Nkind (Label) = N_Label); 10384 10385 -- Generate a goto statement to skip the rest of the accept 10386 10387 Skip_Stmt := 10388 Make_Goto_Statement (Loc, 10389 Name => 10390 New_Occurrence_Of (Entity (Identifier (Label)), Loc)); 10391 end; 10392 end if; 10393 10394 Set_Analyzed (Skip_Stmt); 10395 10396 return Skip_Stmt; 10397 end Build_Skip_Statement; 10398 10399 -- Start of processing for Expand_N_Requeue_Statement 10400 10401 begin 10402 -- Extract the components of the entry call 10403 10404 Extract_Entry (N, Concval, Ename, Index); 10405 Conc_Typ := Etype (Concval); 10406 10407 -- If the prefix is an access to class-wide type, dereference to get 10408 -- object and entry type. 10409 10410 if Is_Access_Type (Conc_Typ) then 10411 Conc_Typ := Designated_Type (Conc_Typ); 10412 Rewrite (Concval, 10413 Make_Explicit_Dereference (Loc, Relocate_Node (Concval))); 10414 Analyze_And_Resolve (Concval, Conc_Typ); 10415 end if; 10416 10417 -- Examine the scope stack in order to find nearest enclosing protected 10418 -- or task type. This will constitute our invocation source. 10419 10420 Old_Typ := Current_Scope; 10421 while Present (Old_Typ) 10422 and then not Is_Protected_Type (Old_Typ) 10423 and then not Is_Task_Type (Old_Typ) 10424 loop 10425 Old_Typ := Scope (Old_Typ); 10426 end loop; 10427 10428 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form 10429 -- Concval.Ename where the type of Concval is class-wide concurrent 10430 -- interface. 10431 10432 if Ada_Version >= Ada_2012 10433 and then Present (Concval) 10434 and then Is_Class_Wide_Type (Conc_Typ) 10435 and then Is_Concurrent_Interface (Conc_Typ) 10436 then 10437 declare 10438 Has_Impl : Boolean := False; 10439 Impl_Kind : Name_Id := No_Name; 10440 10441 begin 10442 -- Check whether the Ename is flagged by pragma Implemented 10443 10444 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then 10445 Has_Impl := True; 10446 Impl_Kind := Implementation_Kind (Entity (Ename)); 10447 end if; 10448 10449 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10450 -- an entry. Create a call to predefined primitive _Disp_Requeue. 10451 10452 if Has_Impl and then Impl_Kind = Name_By_Entry then 10453 Rewrite (N, Build_Dispatching_Requeue); 10454 Analyze (N); 10455 Insert_After (N, Build_Skip_Statement (N)); 10456 10457 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10458 -- a protected procedure. In this case the requeue is transformed 10459 -- into a dispatching call. 10460 10461 elsif Has_Impl 10462 and then Impl_Kind = Name_By_Protected_Procedure 10463 then 10464 Rewrite (N, Build_Dispatching_Call_Equivalent); 10465 Analyze (N); 10466 10467 -- The procedure_or_entry_NAME's implementation kind is either 10468 -- By_Any, Optional, or pragma Implemented was not applied at all. 10469 -- In this case a runtime test determines whether Ename denotes an 10470 -- entry or a protected procedure and performs the appropriate 10471 -- call. 10472 10473 else 10474 Rewrite (N, Build_Dispatching_Requeue_To_Any); 10475 Analyze (N); 10476 end if; 10477 end; 10478 10479 -- Processing for regular (nondispatching) requeues 10480 10481 else 10482 Rewrite (N, Build_Normal_Requeue); 10483 Analyze (N); 10484 Insert_After (N, Build_Skip_Statement (N)); 10485 end if; 10486 end Expand_N_Requeue_Statement; 10487 10488 ------------------------------- 10489 -- Expand_N_Selective_Accept -- 10490 ------------------------------- 10491 10492 procedure Expand_N_Selective_Accept (N : Node_Id) is 10493 Loc : constant Source_Ptr := Sloc (N); 10494 Alts : constant List_Id := Select_Alternatives (N); 10495 10496 -- Note: in the below declarations a lot of new lists are allocated 10497 -- unconditionally which may well not end up being used. That's not 10498 -- a good idea since it wastes space gratuitously ??? 10499 10500 Accept_Case : List_Id; 10501 Accept_List : constant List_Id := New_List; 10502 10503 Alt : Node_Id; 10504 Alt_List : constant List_Id := New_List; 10505 Alt_Stats : List_Id; 10506 Ann : Entity_Id := Empty; 10507 10508 Check_Guard : Boolean := True; 10509 10510 Decls : constant List_Id := New_List; 10511 Stats : constant List_Id := New_List; 10512 Body_List : constant List_Id := New_List; 10513 Trailing_List : constant List_Id := New_List; 10514 10515 Choices : List_Id; 10516 Else_Present : Boolean := False; 10517 Terminate_Alt : Node_Id := Empty; 10518 Select_Mode : Node_Id; 10519 10520 Delay_Case : List_Id; 10521 Delay_Count : Integer := 0; 10522 Delay_Val : Entity_Id; 10523 Delay_Index : Entity_Id; 10524 Delay_Min : Entity_Id; 10525 Delay_Num : Pos := 1; 10526 Delay_Alt_List : List_Id := New_List; 10527 Delay_List : constant List_Id := New_List; 10528 D : Entity_Id; 10529 M : Entity_Id; 10530 10531 First_Delay : Boolean := True; 10532 Guard_Open : Entity_Id; 10533 10534 End_Lab : Node_Id; 10535 Index : Pos := 1; 10536 Lab : Node_Id; 10537 Num_Alts : Nat; 10538 Num_Accept : Nat := 0; 10539 Proc : Node_Id; 10540 Time_Type : Entity_Id; 10541 Select_Call : Node_Id; 10542 10543 Qnam : constant Entity_Id := 10544 Make_Defining_Identifier (Loc, New_External_Name ('S', 0)); 10545 10546 Xnam : constant Entity_Id := 10547 Make_Defining_Identifier (Loc, New_External_Name ('J', 1)); 10548 10549 ----------------------- 10550 -- Local subprograms -- 10551 ----------------------- 10552 10553 function Accept_Or_Raise return List_Id; 10554 -- For the rare case where delay alternatives all have guards, and 10555 -- all of them are closed, it is still possible that there were open 10556 -- accept alternatives with no callers. We must reexamine the 10557 -- Accept_List, and execute a selective wait with no else if some 10558 -- accept is open. If none, we raise program_error. 10559 10560 procedure Add_Accept (Alt : Node_Id); 10561 -- Process a single accept statement in a select alternative. Build 10562 -- procedure for body of accept, and add entry to dispatch table with 10563 -- expression for guard, in preparation for call to run time select. 10564 10565 function Make_And_Declare_Label (Num : Int) return Node_Id; 10566 -- Manufacture a label using Num as a serial number and declare it. 10567 -- The declaration is appended to Decls. The label marks the trailing 10568 -- statements of an accept or delay alternative. 10569 10570 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; 10571 -- Build call to Selective_Wait runtime routine 10572 10573 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); 10574 -- Add code to compare value of delay with previous values, and 10575 -- generate case entry for trailing statements. 10576 10577 procedure Process_Accept_Alternative 10578 (Alt : Node_Id; 10579 Index : Int; 10580 Proc : Node_Id); 10581 -- Add code to call corresponding procedure, and branch to 10582 -- trailing statements, if any. 10583 10584 --------------------- 10585 -- Accept_Or_Raise -- 10586 --------------------- 10587 10588 function Accept_Or_Raise return List_Id is 10589 Cond : Node_Id; 10590 Stats : List_Id; 10591 J : constant Entity_Id := Make_Temporary (Loc, 'J'); 10592 10593 begin 10594 -- We generate the following: 10595 10596 -- for J in q'range loop 10597 -- if q(J).S /=null_task_entry then 10598 -- selective_wait (simple_mode,...); 10599 -- done := True; 10600 -- exit; 10601 -- end if; 10602 -- end loop; 10603 -- 10604 -- if no rendez_vous then 10605 -- raise program_error; 10606 -- end if; 10607 10608 -- Note that the code needs to know that the selector name 10609 -- in an Accept_Alternative is named S. 10610 10611 Cond := Make_Op_Ne (Loc, 10612 Left_Opnd => 10613 Make_Selected_Component (Loc, 10614 Prefix => 10615 Make_Indexed_Component (Loc, 10616 Prefix => New_Occurrence_Of (Qnam, Loc), 10617 Expressions => New_List (New_Occurrence_Of (J, Loc))), 10618 Selector_Name => Make_Identifier (Loc, Name_S)), 10619 Right_Opnd => 10620 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc)); 10621 10622 Stats := New_List ( 10623 Make_Implicit_Loop_Statement (N, 10624 Iteration_Scheme => 10625 Make_Iteration_Scheme (Loc, 10626 Loop_Parameter_Specification => 10627 Make_Loop_Parameter_Specification (Loc, 10628 Defining_Identifier => J, 10629 Discrete_Subtype_Definition => 10630 Make_Attribute_Reference (Loc, 10631 Prefix => New_Occurrence_Of (Qnam, Loc), 10632 Attribute_Name => Name_Range, 10633 Expressions => New_List ( 10634 Make_Integer_Literal (Loc, 1))))), 10635 10636 Statements => New_List ( 10637 Make_Implicit_If_Statement (N, 10638 Condition => Cond, 10639 Then_Statements => New_List ( 10640 Make_Select_Call ( 10641 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)), 10642 Make_Exit_Statement (Loc)))))); 10643 10644 Append_To (Stats, 10645 Make_Raise_Program_Error (Loc, 10646 Condition => Make_Op_Eq (Loc, 10647 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 10648 Right_Opnd => 10649 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 10650 Reason => PE_All_Guards_Closed)); 10651 10652 return Stats; 10653 end Accept_Or_Raise; 10654 10655 ---------------- 10656 -- Add_Accept -- 10657 ---------------- 10658 10659 procedure Add_Accept (Alt : Node_Id) is 10660 Acc_Stm : constant Node_Id := Accept_Statement (Alt); 10661 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm); 10662 Eloc : constant Source_Ptr := Sloc (Ename); 10663 Eent : constant Entity_Id := Entity (Ename); 10664 Index : constant Node_Id := Entry_Index (Acc_Stm); 10665 10666 Call : Node_Id; 10667 Expr : Node_Id; 10668 Null_Body : Node_Id; 10669 PB_Ent : Entity_Id; 10670 Proc_Body : Node_Id; 10671 10672 -- Start of processing for Add_Accept 10673 10674 begin 10675 if No (Ann) then 10676 Ann := Node (Last_Elmt (Accept_Address (Eent))); 10677 end if; 10678 10679 if Present (Condition (Alt)) then 10680 Expr := 10681 Make_If_Expression (Eloc, New_List ( 10682 Condition (Alt), 10683 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)), 10684 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc))); 10685 else 10686 Expr := Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)); 10687 end if; 10688 10689 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then 10690 Null_Body := New_Occurrence_Of (Standard_False, Eloc); 10691 10692 -- Always add call to Abort_Undefer when generating code, since 10693 -- this is what the runtime expects (abort deferred in 10694 -- Selective_Wait). In CodePeer mode this only confuses the 10695 -- analysis with unknown calls, so don't do it. 10696 10697 if not CodePeer_Mode then 10698 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 10699 Insert_Before 10700 (First (Statements (Handled_Statement_Sequence 10701 (Accept_Statement (Alt)))), 10702 Call); 10703 Analyze (Call); 10704 end if; 10705 10706 PB_Ent := 10707 Make_Defining_Identifier (Eloc, 10708 New_External_Name (Chars (Ename), 'A', Num_Accept)); 10709 10710 -- Link the acceptor to the original receiving entry 10711 10712 Set_Ekind (PB_Ent, E_Procedure); 10713 Set_Receiving_Entry (PB_Ent, Eent); 10714 10715 if Comes_From_Source (Alt) then 10716 Set_Debug_Info_Needed (PB_Ent); 10717 end if; 10718 10719 Proc_Body := 10720 Make_Subprogram_Body (Eloc, 10721 Specification => 10722 Make_Procedure_Specification (Eloc, 10723 Defining_Unit_Name => PB_Ent), 10724 Declarations => Declarations (Acc_Stm), 10725 Handled_Statement_Sequence => 10726 Build_Accept_Body (Accept_Statement (Alt))); 10727 10728 Reset_Scopes_To (Proc_Body, PB_Ent); 10729 10730 -- During the analysis of the body of the accept statement, any 10731 -- zero cost exception handler records were collected in the 10732 -- Accept_Handler_Records field of the N_Accept_Alternative node. 10733 -- This is where we move them to where they belong, namely the 10734 -- newly created procedure. 10735 10736 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); 10737 Append (Proc_Body, Body_List); 10738 10739 else 10740 Null_Body := New_Occurrence_Of (Standard_True, Eloc); 10741 10742 -- if accept statement has declarations, insert above, given that 10743 -- we are not creating a body for the accept. 10744 10745 if Present (Declarations (Acc_Stm)) then 10746 Insert_Actions (N, Declarations (Acc_Stm)); 10747 end if; 10748 end if; 10749 10750 Append_To (Accept_List, 10751 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr))); 10752 10753 Num_Accept := Num_Accept + 1; 10754 end Add_Accept; 10755 10756 ---------------------------- 10757 -- Make_And_Declare_Label -- 10758 ---------------------------- 10759 10760 function Make_And_Declare_Label (Num : Int) return Node_Id is 10761 Lab_Id : Node_Id; 10762 10763 begin 10764 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num)); 10765 Lab := 10766 Make_Label (Loc, Lab_Id); 10767 10768 Append_To (Decls, 10769 Make_Implicit_Label_Declaration (Loc, 10770 Defining_Identifier => 10771 Make_Defining_Identifier (Loc, Chars (Lab_Id)), 10772 Label_Construct => Lab)); 10773 10774 return Lab; 10775 end Make_And_Declare_Label; 10776 10777 ---------------------- 10778 -- Make_Select_Call -- 10779 ---------------------- 10780 10781 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is 10782 Params : constant List_Id := New_List; 10783 10784 begin 10785 Append_To (Params, 10786 Make_Attribute_Reference (Loc, 10787 Prefix => New_Occurrence_Of (Qnam, Loc), 10788 Attribute_Name => Name_Unchecked_Access)); 10789 Append_To (Params, Select_Mode); 10790 Append_To (Params, New_Occurrence_Of (Ann, Loc)); 10791 Append_To (Params, New_Occurrence_Of (Xnam, Loc)); 10792 10793 return 10794 Make_Procedure_Call_Statement (Loc, 10795 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc), 10796 Parameter_Associations => Params); 10797 end Make_Select_Call; 10798 10799 -------------------------------- 10800 -- Process_Accept_Alternative -- 10801 -------------------------------- 10802 10803 procedure Process_Accept_Alternative 10804 (Alt : Node_Id; 10805 Index : Int; 10806 Proc : Node_Id) 10807 is 10808 Astmt : constant Node_Id := Accept_Statement (Alt); 10809 Alt_Stats : List_Id; 10810 10811 begin 10812 Adjust_Condition (Condition (Alt)); 10813 10814 -- Accept with body 10815 10816 if Present (Handled_Statement_Sequence (Astmt)) then 10817 Alt_Stats := 10818 New_List ( 10819 Make_Procedure_Call_Statement (Sloc (Proc), 10820 Name => 10821 New_Occurrence_Of 10822 (Defining_Unit_Name (Specification (Proc)), 10823 Sloc (Proc)))); 10824 10825 -- Accept with no body (followed by trailing statements) 10826 10827 else 10828 Alt_Stats := Empty_List; 10829 end if; 10830 10831 Ensure_Statement_Present (Sloc (Astmt), Alt); 10832 10833 -- After the call, if any, branch to trailing statements, if any. 10834 -- We create a label for each, as well as the corresponding label 10835 -- declaration. 10836 10837 if not Is_Empty_List (Statements (Alt)) then 10838 Lab := Make_And_Declare_Label (Index); 10839 Append (Lab, Trailing_List); 10840 Append_List (Statements (Alt), Trailing_List); 10841 Append_To (Trailing_List, 10842 Make_Goto_Statement (Loc, 10843 Name => New_Copy (Identifier (End_Lab)))); 10844 10845 else 10846 Lab := End_Lab; 10847 end if; 10848 10849 Append_To (Alt_Stats, 10850 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab)))); 10851 10852 Append_To (Alt_List, 10853 Make_Case_Statement_Alternative (Loc, 10854 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)), 10855 Statements => Alt_Stats)); 10856 end Process_Accept_Alternative; 10857 10858 ------------------------------- 10859 -- Process_Delay_Alternative -- 10860 ------------------------------- 10861 10862 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is 10863 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt)); 10864 Cond : Node_Id; 10865 Delay_Alt : List_Id; 10866 10867 begin 10868 -- Deal with C/Fortran boolean as delay condition 10869 10870 Adjust_Condition (Condition (Alt)); 10871 10872 -- Determine the smallest specified delay 10873 10874 -- for each delay alternative generate: 10875 10876 -- if guard-expression then 10877 -- Delay_Val := delay-expression; 10878 -- Guard_Open := True; 10879 -- if Delay_Val < Delay_Min then 10880 -- Delay_Min := Delay_Val; 10881 -- Delay_Index := Index; 10882 -- end if; 10883 -- end if; 10884 10885 -- The enclosing if-statement is omitted if there is no guard 10886 10887 if Delay_Count = 1 or else First_Delay then 10888 First_Delay := False; 10889 10890 Delay_Alt := New_List ( 10891 Make_Assignment_Statement (Loc, 10892 Name => New_Occurrence_Of (Delay_Min, Loc), 10893 Expression => Expression (Delay_Statement (Alt)))); 10894 10895 if Delay_Count > 1 then 10896 Append_To (Delay_Alt, 10897 Make_Assignment_Statement (Loc, 10898 Name => New_Occurrence_Of (Delay_Index, Loc), 10899 Expression => Make_Integer_Literal (Loc, Index))); 10900 end if; 10901 10902 else 10903 Delay_Alt := New_List ( 10904 Make_Assignment_Statement (Loc, 10905 Name => New_Occurrence_Of (Delay_Val, Loc), 10906 Expression => Expression (Delay_Statement (Alt)))); 10907 10908 if Time_Type = Standard_Duration then 10909 Cond := 10910 Make_Op_Lt (Loc, 10911 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc), 10912 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc)); 10913 10914 else 10915 -- The scope of the time type must define a comparison 10916 -- operator. The scope itself may not be visible, so we 10917 -- construct a node with entity information to insure that 10918 -- semantic analysis can find the proper operator. 10919 10920 Cond := 10921 Make_Function_Call (Loc, 10922 Name => Make_Selected_Component (Loc, 10923 Prefix => 10924 New_Occurrence_Of (Scope (Time_Type), Loc), 10925 Selector_Name => 10926 Make_Operator_Symbol (Loc, 10927 Chars => Name_Op_Lt, 10928 Strval => No_String)), 10929 Parameter_Associations => 10930 New_List ( 10931 New_Occurrence_Of (Delay_Val, Loc), 10932 New_Occurrence_Of (Delay_Min, Loc))); 10933 10934 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type)); 10935 end if; 10936 10937 Append_To (Delay_Alt, 10938 Make_Implicit_If_Statement (N, 10939 Condition => Cond, 10940 Then_Statements => New_List ( 10941 Make_Assignment_Statement (Loc, 10942 Name => New_Occurrence_Of (Delay_Min, Loc), 10943 Expression => New_Occurrence_Of (Delay_Val, Loc)), 10944 10945 Make_Assignment_Statement (Loc, 10946 Name => New_Occurrence_Of (Delay_Index, Loc), 10947 Expression => Make_Integer_Literal (Loc, Index))))); 10948 end if; 10949 10950 if Check_Guard then 10951 Append_To (Delay_Alt, 10952 Make_Assignment_Statement (Loc, 10953 Name => New_Occurrence_Of (Guard_Open, Loc), 10954 Expression => New_Occurrence_Of (Standard_True, Loc))); 10955 end if; 10956 10957 if Present (Condition (Alt)) then 10958 Delay_Alt := New_List ( 10959 Make_Implicit_If_Statement (N, 10960 Condition => Condition (Alt), 10961 Then_Statements => Delay_Alt)); 10962 end if; 10963 10964 Append_List (Delay_Alt, Delay_List); 10965 10966 Ensure_Statement_Present (Dloc, Alt); 10967 10968 -- If the delay alternative has a statement part, add choice to the 10969 -- case statements for delays. 10970 10971 if not Is_Empty_List (Statements (Alt)) then 10972 10973 if Delay_Count = 1 then 10974 Append_List (Statements (Alt), Delay_Alt_List); 10975 10976 else 10977 Append_To (Delay_Alt_List, 10978 Make_Case_Statement_Alternative (Loc, 10979 Discrete_Choices => New_List ( 10980 Make_Integer_Literal (Loc, Index)), 10981 Statements => Statements (Alt))); 10982 end if; 10983 10984 elsif Delay_Count = 1 then 10985 10986 -- If the single delay has no trailing statements, add a branch 10987 -- to the exit label to the selective wait. 10988 10989 Delay_Alt_List := New_List ( 10990 Make_Goto_Statement (Loc, 10991 Name => New_Copy (Identifier (End_Lab)))); 10992 10993 end if; 10994 end Process_Delay_Alternative; 10995 10996 -- Start of processing for Expand_N_Selective_Accept 10997 10998 begin 10999 Process_Statements_For_Controlled_Objects (N); 11000 11001 -- First insert some declarations before the select. The first is: 11002 11003 -- Ann : Address 11004 11005 -- This variable holds the parameters passed to the accept body. This 11006 -- declaration has already been inserted by the time we get here by 11007 -- a call to Expand_Accept_Declarations made from the semantics when 11008 -- processing the first accept statement contained in the select. We 11009 -- can find this entity as Accept_Address (E), where E is any of the 11010 -- entries references by contained accept statements. 11011 11012 -- The first step is to scan the list of Selective_Accept_Statements 11013 -- to find this entity, and also count the number of accepts, and 11014 -- determine if terminated, delay or else is present: 11015 11016 Num_Alts := 0; 11017 11018 Alt := First (Alts); 11019 while Present (Alt) loop 11020 Process_Statements_For_Controlled_Objects (Alt); 11021 11022 if Nkind (Alt) = N_Accept_Alternative then 11023 Add_Accept (Alt); 11024 11025 elsif Nkind (Alt) = N_Delay_Alternative then 11026 Delay_Count := Delay_Count + 1; 11027 11028 -- If the delays are relative delays, the delay expressions have 11029 -- type Standard_Duration. Otherwise they must have some time type 11030 -- recognized by GNAT. 11031 11032 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then 11033 Time_Type := Standard_Duration; 11034 else 11035 Time_Type := Etype (Expression (Delay_Statement (Alt))); 11036 11037 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) 11038 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time) 11039 then 11040 null; 11041 else 11042 Error_Msg_NE ( 11043 "& is not a time type (RM 9.6(6))", 11044 Expression (Delay_Statement (Alt)), Time_Type); 11045 Time_Type := Standard_Duration; 11046 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type); 11047 end if; 11048 end if; 11049 11050 if No (Condition (Alt)) then 11051 11052 -- This guard will always be open 11053 11054 Check_Guard := False; 11055 end if; 11056 11057 elsif Nkind (Alt) = N_Terminate_Alternative then 11058 Adjust_Condition (Condition (Alt)); 11059 Terminate_Alt := Alt; 11060 end if; 11061 11062 Num_Alts := Num_Alts + 1; 11063 Next (Alt); 11064 end loop; 11065 11066 Else_Present := Present (Else_Statements (N)); 11067 11068 -- At the same time (see procedure Add_Accept) we build the accept list: 11069 11070 -- Qnn : Accept_List (1 .. num-select) := ( 11071 -- (null-body, entry-index), 11072 -- (null-body, entry-index), 11073 -- .. 11074 -- (null_body, entry-index)); 11075 11076 -- In the above declaration, null-body is True if the corresponding 11077 -- accept has no body, and false otherwise. The entry is either the 11078 -- entry index expression if there is no guard, or if a guard is 11079 -- present, then an if expression of the form: 11080 11081 -- (if guard then entry-index else Null_Task_Entry) 11082 11083 -- If a guard is statically known to be false, the entry can simply 11084 -- be omitted from the accept list. 11085 11086 Append_To (Decls, 11087 Make_Object_Declaration (Loc, 11088 Defining_Identifier => Qnam, 11089 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc), 11090 Aliased_Present => True, 11091 Expression => 11092 Make_Qualified_Expression (Loc, 11093 Subtype_Mark => 11094 New_Occurrence_Of (RTE (RE_Accept_List), Loc), 11095 Expression => 11096 Make_Aggregate (Loc, Expressions => Accept_List)))); 11097 11098 -- Then we declare the variable that holds the index for the accept 11099 -- that will be selected for service: 11100 11101 -- Xnn : Select_Index; 11102 11103 Append_To (Decls, 11104 Make_Object_Declaration (Loc, 11105 Defining_Identifier => Xnam, 11106 Object_Definition => 11107 New_Occurrence_Of (RTE (RE_Select_Index), Loc), 11108 Expression => 11109 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc))); 11110 11111 -- After this follow procedure declarations for each accept body 11112 11113 -- procedure Pnn is 11114 -- begin 11115 -- ... 11116 -- end; 11117 11118 -- where the ... are statements from the corresponding procedure body. 11119 -- No parameters are involved, since the parameters are passed via Ann 11120 -- and the parameter references have already been expanded to be direct 11121 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, 11122 -- any embedded tasking statements (which would normally be illegal in 11123 -- procedures), have been converted to calls to the tasking runtime so 11124 -- there is no problem in putting them into procedures. 11125 11126 -- The original accept statement has been expanded into a block in 11127 -- the same fashion as for simple accepts (see Build_Accept_Body). 11128 11129 -- Note: we don't really need to build these procedures for the case 11130 -- where no delay statement is present, but it is just as easy to 11131 -- build them unconditionally, and not significantly inefficient, 11132 -- since if they are short they will be inlined anyway. 11133 11134 -- The procedure declarations have been assembled in Body_List 11135 11136 -- If delays are present, we must compute the required delay. 11137 -- We first generate the declarations: 11138 11139 -- Delay_Index : Boolean := 0; 11140 -- Delay_Min : Some_Time_Type.Time; 11141 -- Delay_Val : Some_Time_Type.Time; 11142 11143 -- Delay_Index will be set to the index of the minimum delay, i.e. the 11144 -- active delay that is actually chosen as the basis for the possible 11145 -- delay if an immediate rendez-vous is not possible. 11146 11147 -- In the most common case there is a single delay statement, and this 11148 -- is handled specially. 11149 11150 if Delay_Count > 0 then 11151 11152 -- Generate the required declarations 11153 11154 Delay_Val := 11155 Make_Defining_Identifier (Loc, New_External_Name ('D', 1)); 11156 Delay_Index := 11157 Make_Defining_Identifier (Loc, New_External_Name ('D', 2)); 11158 Delay_Min := 11159 Make_Defining_Identifier (Loc, New_External_Name ('D', 3)); 11160 11161 Append_To (Decls, 11162 Make_Object_Declaration (Loc, 11163 Defining_Identifier => Delay_Val, 11164 Object_Definition => New_Occurrence_Of (Time_Type, Loc))); 11165 11166 Append_To (Decls, 11167 Make_Object_Declaration (Loc, 11168 Defining_Identifier => Delay_Index, 11169 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 11170 Expression => Make_Integer_Literal (Loc, 0))); 11171 11172 Append_To (Decls, 11173 Make_Object_Declaration (Loc, 11174 Defining_Identifier => Delay_Min, 11175 Object_Definition => New_Occurrence_Of (Time_Type, Loc), 11176 Expression => 11177 Unchecked_Convert_To (Time_Type, 11178 Make_Attribute_Reference (Loc, 11179 Prefix => 11180 New_Occurrence_Of (Underlying_Type (Time_Type), Loc), 11181 Attribute_Name => Name_Last)))); 11182 11183 -- Create Duration and Delay_Mode objects used for passing a delay 11184 -- value to RTS 11185 11186 D := Make_Temporary (Loc, 'D'); 11187 M := Make_Temporary (Loc, 'M'); 11188 11189 declare 11190 Discr : Entity_Id; 11191 11192 begin 11193 -- Note that these values are defined in s-osprim.ads and must 11194 -- be kept in sync: 11195 -- 11196 -- Relative : constant := 0; 11197 -- Absolute_Calendar : constant := 1; 11198 -- Absolute_RT : constant := 2; 11199 11200 if Time_Type = Standard_Duration then 11201 Discr := Make_Integer_Literal (Loc, 0); 11202 11203 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11204 Discr := Make_Integer_Literal (Loc, 1); 11205 11206 else 11207 pragma Assert 11208 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11209 Discr := Make_Integer_Literal (Loc, 2); 11210 end if; 11211 11212 Append_To (Decls, 11213 Make_Object_Declaration (Loc, 11214 Defining_Identifier => D, 11215 Object_Definition => 11216 New_Occurrence_Of (Standard_Duration, Loc))); 11217 11218 Append_To (Decls, 11219 Make_Object_Declaration (Loc, 11220 Defining_Identifier => M, 11221 Object_Definition => 11222 New_Occurrence_Of (Standard_Integer, Loc), 11223 Expression => Discr)); 11224 end; 11225 11226 if Check_Guard then 11227 Guard_Open := 11228 Make_Defining_Identifier (Loc, New_External_Name ('G', 1)); 11229 11230 Append_To (Decls, 11231 Make_Object_Declaration (Loc, 11232 Defining_Identifier => Guard_Open, 11233 Object_Definition => 11234 New_Occurrence_Of (Standard_Boolean, Loc), 11235 Expression => 11236 New_Occurrence_Of (Standard_False, Loc))); 11237 end if; 11238 11239 -- Delay_Count is zero, don't need M and D set (suppress warning) 11240 11241 else 11242 M := Empty; 11243 D := Empty; 11244 end if; 11245 11246 if Present (Terminate_Alt) then 11247 11248 -- If the terminate alternative guard is False, use 11249 -- Simple_Mode; otherwise use Terminate_Mode. 11250 11251 if Present (Condition (Terminate_Alt)) then 11252 Select_Mode := Make_If_Expression (Loc, 11253 New_List (Condition (Terminate_Alt), 11254 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc), 11255 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc))); 11256 else 11257 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc); 11258 end if; 11259 11260 elsif Else_Present or Delay_Count > 0 then 11261 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc); 11262 11263 else 11264 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc); 11265 end if; 11266 11267 Select_Call := Make_Select_Call (Select_Mode); 11268 Append (Select_Call, Stats); 11269 11270 -- Now generate code to act on the result. There is an entry 11271 -- in this case for each accept statement with a non-null body, 11272 -- followed by a branch to the statements that follow the Accept. 11273 -- In the absence of delay alternatives, we generate: 11274 11275 -- case X is 11276 -- when No_Rendezvous => -- omitted if simple mode 11277 -- goto Lab0; 11278 11279 -- when 1 => 11280 -- P1n; 11281 -- goto Lab1; 11282 11283 -- when 2 => 11284 -- P2n; 11285 -- goto Lab2; 11286 11287 -- when others => 11288 -- goto Exit; 11289 -- end case; 11290 -- 11291 -- Lab0: Else_Statements; 11292 -- goto exit; 11293 11294 -- Lab1: Trailing_Statements1; 11295 -- goto Exit; 11296 -- 11297 -- Lab2: Trailing_Statements2; 11298 -- goto Exit; 11299 -- ... 11300 -- Exit: 11301 11302 -- Generate label for common exit 11303 11304 End_Lab := Make_And_Declare_Label (Num_Alts + 1); 11305 11306 -- First entry is the default case, when no rendezvous is possible 11307 11308 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)); 11309 11310 if Else_Present then 11311 11312 -- If no rendezvous is possible, the else part is executed 11313 11314 Lab := Make_And_Declare_Label (0); 11315 Alt_Stats := New_List ( 11316 Make_Goto_Statement (Loc, 11317 Name => New_Copy (Identifier (Lab)))); 11318 11319 Append (Lab, Trailing_List); 11320 Append_List (Else_Statements (N), Trailing_List); 11321 Append_To (Trailing_List, 11322 Make_Goto_Statement (Loc, 11323 Name => New_Copy (Identifier (End_Lab)))); 11324 else 11325 Alt_Stats := New_List ( 11326 Make_Goto_Statement (Loc, 11327 Name => New_Copy (Identifier (End_Lab)))); 11328 end if; 11329 11330 Append_To (Alt_List, 11331 Make_Case_Statement_Alternative (Loc, 11332 Discrete_Choices => Choices, 11333 Statements => Alt_Stats)); 11334 11335 -- We make use of the fact that Accept_Index is an integer type, and 11336 -- generate successive literals for entries for each accept. Only those 11337 -- for which there is a body or trailing statements get a case entry. 11338 11339 Alt := First (Select_Alternatives (N)); 11340 Proc := First (Body_List); 11341 while Present (Alt) loop 11342 11343 if Nkind (Alt) = N_Accept_Alternative then 11344 Process_Accept_Alternative (Alt, Index, Proc); 11345 Index := Index + 1; 11346 11347 if Present 11348 (Handled_Statement_Sequence (Accept_Statement (Alt))) 11349 then 11350 Next (Proc); 11351 end if; 11352 11353 elsif Nkind (Alt) = N_Delay_Alternative then 11354 Process_Delay_Alternative (Alt, Delay_Num); 11355 Delay_Num := Delay_Num + 1; 11356 end if; 11357 11358 Next (Alt); 11359 end loop; 11360 11361 -- An others choice is always added to the main case, as well 11362 -- as the delay case (to satisfy the compiler). 11363 11364 Append_To (Alt_List, 11365 Make_Case_Statement_Alternative (Loc, 11366 Discrete_Choices => 11367 New_List (Make_Others_Choice (Loc)), 11368 Statements => 11369 New_List (Make_Goto_Statement (Loc, 11370 Name => New_Copy (Identifier (End_Lab)))))); 11371 11372 Accept_Case := New_List ( 11373 Make_Case_Statement (Loc, 11374 Expression => New_Occurrence_Of (Xnam, Loc), 11375 Alternatives => Alt_List)); 11376 11377 Append_List (Trailing_List, Accept_Case); 11378 Append_List (Body_List, Decls); 11379 11380 -- Construct case statement for trailing statements of delay 11381 -- alternatives, if there are several of them. 11382 11383 if Delay_Count > 1 then 11384 Append_To (Delay_Alt_List, 11385 Make_Case_Statement_Alternative (Loc, 11386 Discrete_Choices => 11387 New_List (Make_Others_Choice (Loc)), 11388 Statements => 11389 New_List (Make_Null_Statement (Loc)))); 11390 11391 Delay_Case := New_List ( 11392 Make_Case_Statement (Loc, 11393 Expression => New_Occurrence_Of (Delay_Index, Loc), 11394 Alternatives => Delay_Alt_List)); 11395 else 11396 Delay_Case := Delay_Alt_List; 11397 end if; 11398 11399 -- If there are no delay alternatives, we append the case statement 11400 -- to the statement list. 11401 11402 if Delay_Count = 0 then 11403 Append_List (Accept_Case, Stats); 11404 11405 -- Delay alternatives present 11406 11407 else 11408 -- If delay alternatives are present we generate: 11409 11410 -- find minimum delay. 11411 -- DX := minimum delay; 11412 -- M := <delay mode>; 11413 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P, 11414 -- DX, MX, X); 11415 -- 11416 -- if X = No_Rendezvous then 11417 -- case statement for delay statements. 11418 -- else 11419 -- case statement for accept alternatives. 11420 -- end if; 11421 11422 declare 11423 Cases : Node_Id; 11424 Stmt : Node_Id; 11425 Parms : List_Id; 11426 Parm : Node_Id; 11427 Conv : Node_Id; 11428 11429 begin 11430 -- The type of the delay expression is known to be legal 11431 11432 if Time_Type = Standard_Duration then 11433 Conv := New_Occurrence_Of (Delay_Min, Loc); 11434 11435 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11436 Conv := Make_Function_Call (Loc, 11437 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 11438 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11439 11440 else 11441 pragma Assert 11442 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11443 11444 Conv := Make_Function_Call (Loc, 11445 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 11446 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11447 end if; 11448 11449 Stmt := Make_Assignment_Statement (Loc, 11450 Name => New_Occurrence_Of (D, Loc), 11451 Expression => Conv); 11452 11453 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) 11454 11455 Parms := Parameter_Associations (Select_Call); 11456 11457 Parm := First (Parms); 11458 while Present (Parm) and then Parm /= Select_Mode loop 11459 Next (Parm); 11460 end loop; 11461 11462 pragma Assert (Present (Parm)); 11463 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc)); 11464 Analyze (Parm); 11465 11466 -- Prepare two new parameters of Duration and Delay_Mode type 11467 -- which represent the value and the mode of the minimum delay. 11468 11469 Next (Parm); 11470 Insert_After (Parm, New_Occurrence_Of (M, Loc)); 11471 Insert_After (Parm, New_Occurrence_Of (D, Loc)); 11472 11473 -- Create a call to RTS 11474 11475 Rewrite (Select_Call, 11476 Make_Procedure_Call_Statement (Loc, 11477 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc), 11478 Parameter_Associations => Parms)); 11479 11480 -- This new call should follow the calculation of the minimum 11481 -- delay. 11482 11483 Insert_List_Before (Select_Call, Delay_List); 11484 11485 if Check_Guard then 11486 Stmt := 11487 Make_Implicit_If_Statement (N, 11488 Condition => New_Occurrence_Of (Guard_Open, Loc), 11489 Then_Statements => New_List ( 11490 New_Copy_Tree (Stmt), 11491 New_Copy_Tree (Select_Call)), 11492 Else_Statements => Accept_Or_Raise); 11493 Rewrite (Select_Call, Stmt); 11494 else 11495 Insert_Before (Select_Call, Stmt); 11496 end if; 11497 11498 Cases := 11499 Make_Implicit_If_Statement (N, 11500 Condition => Make_Op_Eq (Loc, 11501 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 11502 Right_Opnd => 11503 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 11504 11505 Then_Statements => Delay_Case, 11506 Else_Statements => Accept_Case); 11507 11508 Append (Cases, Stats); 11509 end; 11510 end if; 11511 11512 Append (End_Lab, Stats); 11513 11514 -- Replace accept statement with appropriate block 11515 11516 Rewrite (N, 11517 Make_Block_Statement (Loc, 11518 Declarations => Decls, 11519 Handled_Statement_Sequence => 11520 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats))); 11521 Analyze (N); 11522 11523 -- Note: have to worry more about abort deferral in above code ??? 11524 11525 -- Final step is to unstack the Accept_Address entries for all accept 11526 -- statements appearing in accept alternatives in the select statement 11527 11528 Alt := First (Alts); 11529 while Present (Alt) loop 11530 if Nkind (Alt) = N_Accept_Alternative then 11531 Remove_Last_Elmt (Accept_Address 11532 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))); 11533 end if; 11534 11535 Next (Alt); 11536 end loop; 11537 end Expand_N_Selective_Accept; 11538 11539 ------------------------------------------- 11540 -- Expand_N_Single_Protected_Declaration -- 11541 ------------------------------------------- 11542 11543 -- A single protected declaration should never be present after semantic 11544 -- analysis because it is transformed into a protected type declaration 11545 -- and an accompanying anonymous object. This routine ensures that the 11546 -- transformation takes place. 11547 11548 procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is 11549 begin 11550 raise Program_Error; 11551 end Expand_N_Single_Protected_Declaration; 11552 11553 -------------------------------------- 11554 -- Expand_N_Single_Task_Declaration -- 11555 -------------------------------------- 11556 11557 -- A single task declaration should never be present after semantic 11558 -- analysis because it is transformed into a task type declaration and 11559 -- an accompanying anonymous object. This routine ensures that the 11560 -- transformation takes place. 11561 11562 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is 11563 begin 11564 raise Program_Error; 11565 end Expand_N_Single_Task_Declaration; 11566 11567 ------------------------ 11568 -- Expand_N_Task_Body -- 11569 ------------------------ 11570 11571 -- Given a task body 11572 11573 -- task body tname is 11574 -- <declarations> 11575 -- begin 11576 -- <statements> 11577 -- end x; 11578 11579 -- This expansion routine converts it into a procedure and sets the 11580 -- elaboration flag for the procedure to true, to represent the fact 11581 -- that the task body is now elaborated: 11582 11583 -- procedure tnameB (_Task : access tnameV) is 11584 -- discriminal : dtype renames _Task.discriminant; 11585 11586 -- procedure _clean is 11587 -- begin 11588 -- Abort_Defer.all; 11589 -- Complete_Task; 11590 -- Abort_Undefer.all; 11591 -- return; 11592 -- end _clean; 11593 11594 -- begin 11595 -- Abort_Undefer.all; 11596 -- <declarations> 11597 -- System.Task_Stages.Complete_Activation; 11598 -- <statements> 11599 -- at end 11600 -- _clean; 11601 -- end tnameB; 11602 11603 -- tnameE := True; 11604 11605 -- In addition, if the task body is an activator, then a call to activate 11606 -- tasks is added at the start of the statements, before the call to 11607 -- Complete_Activation, and if in addition the task is a master then it 11608 -- must be established as a master. These calls are inserted and analyzed 11609 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is 11610 -- expanded. 11611 11612 -- There is one discriminal declaration line generated for each 11613 -- discriminant that is present to provide an easy reference point for 11614 -- discriminant references inside the body (see Exp_Ch2.Expand_Name). 11615 11616 -- Note on relationship to GNARLI definition. In the GNARLI definition, 11617 -- task body procedures have a profile (Arg : System.Address). That is 11618 -- needed because GNARLI has to use the same access-to-subprogram type 11619 -- for all task types. We depend here on knowing that in GNAT, passing 11620 -- an address argument by value is identical to passing a record value 11621 -- by access (in either case a single pointer is passed), so even though 11622 -- this procedure has the wrong profile. In fact it's all OK, since the 11623 -- callings sequence is identical. 11624 11625 procedure Expand_N_Task_Body (N : Node_Id) is 11626 Loc : constant Source_Ptr := Sloc (N); 11627 Ttyp : constant Entity_Id := Corresponding_Spec (N); 11628 Call : Node_Id; 11629 New_N : Node_Id; 11630 11631 Insert_Nod : Node_Id; 11632 -- Used to determine the proper location of wrapper body insertions 11633 11634 begin 11635 -- if no task body procedure, means we had an error in configurable 11636 -- run-time mode, and there is no point in proceeding further. 11637 11638 if No (Task_Body_Procedure (Ttyp)) then 11639 return; 11640 end if; 11641 11642 -- Add renaming declarations for discriminals and a declaration for the 11643 -- entry family index (if applicable). 11644 11645 Install_Private_Data_Declarations 11646 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N)); 11647 11648 -- Add a call to Abort_Undefer at the very beginning of the task 11649 -- body since this body is called with abort still deferred. 11650 11651 if Abort_Allowed then 11652 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 11653 Insert_Before 11654 (First (Statements (Handled_Statement_Sequence (N))), Call); 11655 Analyze (Call); 11656 end if; 11657 11658 -- The statement part has already been protected with an at_end and 11659 -- cleanup actions. The call to Complete_Activation must be placed 11660 -- at the head of the sequence of statements of that block. The 11661 -- declarations have been merged in this sequence of statements but 11662 -- the first real statement is accessible from the First_Real_Statement 11663 -- field (which was set for exactly this purpose). 11664 11665 if Restricted_Profile then 11666 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); 11667 else 11668 Call := Build_Runtime_Call (Loc, RE_Complete_Activation); 11669 end if; 11670 11671 Insert_Before 11672 (First_Real_Statement (Handled_Statement_Sequence (N)), Call); 11673 Analyze (Call); 11674 11675 New_N := 11676 Make_Subprogram_Body (Loc, 11677 Specification => Build_Task_Proc_Specification (Ttyp), 11678 Declarations => Declarations (N), 11679 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 11680 Set_Is_Task_Body_Procedure (New_N); 11681 11682 -- If the task contains generic instantiations, cleanup actions are 11683 -- delayed until after instantiation. Transfer the activation chain to 11684 -- the subprogram, to insure that the activation call is properly 11685 -- generated. It the task body contains inner tasks, indicate that the 11686 -- subprogram is a task master. 11687 11688 if Delay_Cleanups (Ttyp) then 11689 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); 11690 Set_Is_Task_Master (New_N, Is_Task_Master (N)); 11691 end if; 11692 11693 Rewrite (N, New_N); 11694 Analyze (N); 11695 11696 -- Set elaboration flag immediately after task body. If the body is a 11697 -- subunit, the flag is set in the declarative part containing the stub. 11698 11699 if Nkind (Parent (N)) /= N_Subunit then 11700 Insert_After (N, 11701 Make_Assignment_Statement (Loc, 11702 Name => 11703 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), 11704 Expression => New_Occurrence_Of (Standard_True, Loc))); 11705 end if; 11706 11707 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after 11708 -- the task body. At this point all wrapper specs have been created, 11709 -- frozen and included in the dispatch table for the task type. 11710 11711 if Ada_Version >= Ada_2005 then 11712 if Nkind (Parent (N)) = N_Subunit then 11713 Insert_Nod := Corresponding_Stub (Parent (N)); 11714 else 11715 Insert_Nod := N; 11716 end if; 11717 11718 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod); 11719 end if; 11720 end Expand_N_Task_Body; 11721 11722 ------------------------------------ 11723 -- Expand_N_Task_Type_Declaration -- 11724 ------------------------------------ 11725 11726 -- We have several things to do. First we must create a Boolean flag used 11727 -- to mark if the body is elaborated yet. This variable gets set to True 11728 -- when the body of the task is elaborated (we can't rely on the normal 11729 -- ABE mechanism for the task body, since we need to pass an access to 11730 -- this elaboration boolean to the runtime routines). 11731 11732 -- taskE : aliased Boolean := False; 11733 11734 -- Next a variable is declared to hold the task stack size (either the 11735 -- default : Unspecified_Size, or a value that is set by a pragma 11736 -- Storage_Size). If the value of the pragma Storage_Size is static, then 11737 -- the variable is initialized with this value: 11738 11739 -- taskZ : Size_Type := Unspecified_Size; 11740 -- or 11741 -- taskZ : Size_Type := Size_Type (size_expression); 11742 11743 -- Note: No variable is needed to hold the task relative deadline since 11744 -- its value would never be static because the parameter is of a private 11745 -- type (Ada.Real_Time.Time_Span). 11746 11747 -- Next we create a corresponding record type declaration used to represent 11748 -- values of this task. The general form of this type declaration is 11749 11750 -- type taskV (discriminants) is record 11751 -- _Task_Id : Task_Id; 11752 -- entry_family : array (bounds) of Void; 11753 -- _Priority : Integer := priority_expression; 11754 -- _Size : Size_Type := size_expression; 11755 -- _Secondary_Stack_Size : Size_Type := size_expression; 11756 -- _Task_Info : Task_Info_Type := task_info_expression; 11757 -- _CPU : Integer := cpu_range_expression; 11758 -- _Relative_Deadline : Time_Span := time_span_expression; 11759 -- _Domain : Dispatching_Domain := dd_expression; 11760 -- end record; 11761 11762 -- The discriminants are present only if the corresponding task type has 11763 -- discriminants, and they exactly mirror the task type discriminants. 11764 11765 -- The Id field is always present. It contains the Task_Id value, as set by 11766 -- the call to Create_Task. Note that although the task is limited, the 11767 -- task value record type is not limited, so there is no problem in passing 11768 -- this field as an out parameter to Create_Task. 11769 11770 -- One entry_family component is present for each entry family in the task 11771 -- definition. The bounds correspond to the bounds of the entry family 11772 -- (which may depend on discriminants). The element type is void, since we 11773 -- only need the bounds information for determining the entry index. Note 11774 -- that the use of an anonymous array would normally be illegal in this 11775 -- context, but this is a parser check, and the semantics is quite prepared 11776 -- to handle such a case. 11777 11778 -- The _Size field is present only if a Storage_Size pragma appears in the 11779 -- task definition. The expression captures the argument that was present 11780 -- in the pragma, and is used to override the task stack size otherwise 11781 -- associated with the task type. 11782 11783 -- The _Secondary_Stack_Size field is present only the task entity has a 11784 -- Secondary_Stack_Size rep item. It will be filled at the freeze point, 11785 -- when the record init proc is built, to capture the expression of the 11786 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot 11787 -- be filled here since aspect evaluations are delayed till the freeze 11788 -- point. 11789 11790 -- The _Priority field is present only if the task entity has a Priority or 11791 -- Interrupt_Priority rep item (pragma, aspect specification or attribute 11792 -- definition clause). It will be filled at the freeze point, when the 11793 -- record init proc is built, to capture the expression of the rep item 11794 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11795 -- here since aspect evaluations are delayed till the freeze point. 11796 11797 -- The _Task_Info field is present only if a Task_Info pragma appears in 11798 -- the task definition. The expression captures the argument that was 11799 -- present in the pragma, and is used to provide the Task_Image parameter 11800 -- to the call to Create_Task. 11801 11802 -- The _CPU field is present only if the task entity has a CPU rep item 11803 -- (pragma, aspect specification or attribute definition clause). It will 11804 -- be filled at the freeze point, when the record init proc is built, to 11805 -- capture the expression of the rep item (see Build_Record_Init_Proc in 11806 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations 11807 -- are delayed till the freeze point. 11808 11809 -- The _Relative_Deadline field is present only if a Relative_Deadline 11810 -- pragma appears in the task definition. The expression captures the 11811 -- argument that was present in the pragma, and is used to provide the 11812 -- Relative_Deadline parameter to the call to Create_Task. 11813 11814 -- The _Domain field is present only if the task entity has a 11815 -- Dispatching_Domain rep item (pragma, aspect specification or attribute 11816 -- definition clause). It will be filled at the freeze point, when the 11817 -- record init proc is built, to capture the expression of the rep item 11818 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11819 -- here since aspect evaluations are delayed till the freeze point. 11820 11821 -- When a task is declared, an instance of the task value record is 11822 -- created. The elaboration of this declaration creates the correct bounds 11823 -- for the entry families, and also evaluates the size, priority, and 11824 -- task_Info expressions if needed. The initialization routine for the task 11825 -- type itself then calls Create_Task with appropriate parameters to 11826 -- initialize the value of the Task_Id field. 11827 11828 -- Note: the address of this record is passed as the "Discriminants" 11829 -- parameter for Create_Task. Since Create_Task merely passes this onto the 11830 -- body procedure, it does not matter that it does not quite match the 11831 -- GNARLI model of what is being passed (the record contains more than just 11832 -- the discriminants, but the discriminants can be found from the record 11833 -- value). 11834 11835 -- The Entity_Id for this created record type is placed in the 11836 -- Corresponding_Record_Type field of the associated task type entity. 11837 11838 -- Next we create a procedure specification for the task body procedure: 11839 11840 -- procedure taskB (_Task : access taskV); 11841 11842 -- Note that this must come after the record type declaration, since 11843 -- the spec refers to this type. It turns out that the initialization 11844 -- procedure for the value type references the task body spec, but that's 11845 -- fine, since it won't be generated till the freeze point for the type, 11846 -- which is certainly after the task body spec declaration. 11847 11848 -- Finally, we set the task index value field of the entry attribute in 11849 -- the case of a simple entry. 11850 11851 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is 11852 Loc : constant Source_Ptr := Sloc (N); 11853 TaskId : constant Entity_Id := Defining_Identifier (N); 11854 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); 11855 Tasknm : constant Name_Id := Chars (Tasktyp); 11856 Taskdef : constant Node_Id := Task_Definition (N); 11857 11858 Body_Decl : Node_Id; 11859 Cdecls : List_Id; 11860 Decl_Stack : Node_Id; 11861 Decl_SS : Node_Id; 11862 Elab_Decl : Node_Id; 11863 Ent_Stack : Entity_Id; 11864 Proc_Spec : Node_Id; 11865 Rec_Decl : Node_Id; 11866 Rec_Ent : Entity_Id; 11867 Size_Decl : Entity_Id; 11868 Task_Size : Node_Id; 11869 11870 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id; 11871 -- Searches the task definition T for the first occurrence of the pragma 11872 -- Relative Deadline. The caller has ensured that the pragma is present 11873 -- in the task definition. Note that this routine cannot be implemented 11874 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are 11875 -- not chained because their expansion into a procedure call statement 11876 -- would cause a break in the chain. 11877 11878 ---------------------------------- 11879 -- Get_Relative_Deadline_Pragma -- 11880 ---------------------------------- 11881 11882 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is 11883 N : Node_Id; 11884 11885 begin 11886 N := First (Visible_Declarations (T)); 11887 while Present (N) loop 11888 if Nkind (N) = N_Pragma 11889 and then Pragma_Name (N) = Name_Relative_Deadline 11890 then 11891 return N; 11892 end if; 11893 11894 Next (N); 11895 end loop; 11896 11897 N := First (Private_Declarations (T)); 11898 while Present (N) loop 11899 if Nkind (N) = N_Pragma 11900 and then Pragma_Name (N) = Name_Relative_Deadline 11901 then 11902 return N; 11903 end if; 11904 11905 Next (N); 11906 end loop; 11907 11908 raise Program_Error; 11909 end Get_Relative_Deadline_Pragma; 11910 11911 -- Start of processing for Expand_N_Task_Type_Declaration 11912 11913 begin 11914 -- If already expanded, nothing to do 11915 11916 if Present (Corresponding_Record_Type (Tasktyp)) then 11917 return; 11918 end if; 11919 11920 -- Here we will do the expansion 11921 11922 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); 11923 11924 Rec_Ent := Defining_Identifier (Rec_Decl); 11925 Cdecls := Component_Items (Component_List 11926 (Type_Definition (Rec_Decl))); 11927 11928 Qualify_Entity_Names (N); 11929 11930 -- First create the elaboration variable 11931 11932 Elab_Decl := 11933 Make_Object_Declaration (Loc, 11934 Defining_Identifier => 11935 Make_Defining_Identifier (Sloc (Tasktyp), 11936 Chars => New_External_Name (Tasknm, 'E')), 11937 Aliased_Present => True, 11938 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 11939 Expression => New_Occurrence_Of (Standard_False, Loc)); 11940 11941 Insert_After (N, Elab_Decl); 11942 11943 -- Next create the declaration of the size variable (tasknmZ) 11944 11945 Set_Storage_Size_Variable (Tasktyp, 11946 Make_Defining_Identifier (Sloc (Tasktyp), 11947 Chars => New_External_Name (Tasknm, 'Z'))); 11948 11949 if Present (Taskdef) 11950 and then Has_Storage_Size_Pragma (Taskdef) 11951 and then 11952 Is_OK_Static_Expression 11953 (Expression 11954 (First (Pragma_Argument_Associations 11955 (Get_Rep_Pragma (TaskId, Name_Storage_Size))))) 11956 then 11957 Size_Decl := 11958 Make_Object_Declaration (Loc, 11959 Defining_Identifier => Storage_Size_Variable (Tasktyp), 11960 Object_Definition => 11961 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 11962 Expression => 11963 Convert_To (RTE (RE_Size_Type), 11964 Relocate_Node 11965 (Expression (First (Pragma_Argument_Associations 11966 (Get_Rep_Pragma 11967 (TaskId, Name_Storage_Size))))))); 11968 11969 else 11970 Size_Decl := 11971 Make_Object_Declaration (Loc, 11972 Defining_Identifier => Storage_Size_Variable (Tasktyp), 11973 Object_Definition => 11974 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 11975 Expression => 11976 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 11977 end if; 11978 11979 Insert_After (Elab_Decl, Size_Decl); 11980 11981 -- Next build the rest of the corresponding record declaration. This is 11982 -- done last, since the corresponding record initialization procedure 11983 -- will reference the previously created entities. 11984 11985 -- Fill in the component declarations -- first the _Task_Id field 11986 11987 Append_To (Cdecls, 11988 Make_Component_Declaration (Loc, 11989 Defining_Identifier => 11990 Make_Defining_Identifier (Loc, Name_uTask_Id), 11991 Component_Definition => 11992 Make_Component_Definition (Loc, 11993 Aliased_Present => False, 11994 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id), 11995 Loc)))); 11996 11997 -- Declare static ATCB (that is, created by the expander) if we are 11998 -- using the Restricted run time. 11999 12000 if Restricted_Profile then 12001 Append_To (Cdecls, 12002 Make_Component_Declaration (Loc, 12003 Defining_Identifier => 12004 Make_Defining_Identifier (Loc, Name_uATCB), 12005 12006 Component_Definition => 12007 Make_Component_Definition (Loc, 12008 Aliased_Present => True, 12009 Subtype_Indication => Make_Subtype_Indication (Loc, 12010 Subtype_Mark => 12011 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc), 12012 12013 Constraint => 12014 Make_Index_Or_Discriminant_Constraint (Loc, 12015 Constraints => 12016 New_List (Make_Integer_Literal (Loc, 0))))))); 12017 12018 end if; 12019 12020 -- Declare static stack (that is, created by the expander) if we are 12021 -- using the Restricted run time on a bare board configuration. 12022 12023 if Restricted_Profile and then Preallocated_Stacks_On_Target then 12024 12025 -- First we need to extract the appropriate stack size 12026 12027 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack); 12028 12029 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 12030 declare 12031 Expr_N : constant Node_Id := 12032 Expression (First ( 12033 Pragma_Argument_Associations ( 12034 Get_Rep_Pragma (TaskId, Name_Storage_Size)))); 12035 Etyp : constant Entity_Id := Etype (Expr_N); 12036 P : constant Node_Id := Parent (Expr_N); 12037 12038 begin 12039 -- The stack is defined inside the corresponding record. 12040 -- Therefore if the size of the stack is set by means of 12041 -- a discriminant, we must reference the discriminant of the 12042 -- corresponding record type. 12043 12044 if Nkind (Expr_N) in N_Has_Entity 12045 and then Present (Discriminal_Link (Entity (Expr_N))) 12046 then 12047 Task_Size := 12048 New_Occurrence_Of 12049 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))), 12050 Loc); 12051 Set_Parent (Task_Size, P); 12052 Set_Etype (Task_Size, Etyp); 12053 Set_Analyzed (Task_Size); 12054 12055 else 12056 Task_Size := New_Copy_Tree (Expr_N); 12057 end if; 12058 end; 12059 12060 else 12061 Task_Size := 12062 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc); 12063 end if; 12064 12065 Decl_Stack := Make_Component_Declaration (Loc, 12066 Defining_Identifier => Ent_Stack, 12067 12068 Component_Definition => 12069 Make_Component_Definition (Loc, 12070 Aliased_Present => True, 12071 Subtype_Indication => Make_Subtype_Indication (Loc, 12072 Subtype_Mark => 12073 New_Occurrence_Of (RTE (RE_Storage_Array), Loc), 12074 12075 Constraint => 12076 Make_Index_Or_Discriminant_Constraint (Loc, 12077 Constraints => New_List (Make_Range (Loc, 12078 Low_Bound => Make_Integer_Literal (Loc, 1), 12079 High_Bound => Convert_To (RTE (RE_Storage_Offset), 12080 Task_Size))))))); 12081 12082 Append_To (Cdecls, Decl_Stack); 12083 12084 -- The appropriate alignment for the stack is ensured by the run-time 12085 -- code in charge of task creation. 12086 12087 end if; 12088 12089 -- Declare a static secondary stack if the conditions for a statically 12090 -- generated stack are met. 12091 12092 if Create_Secondary_Stack_For_Task (TaskId) then 12093 declare 12094 Size_Expr : constant Node_Id := 12095 Expression (First ( 12096 Pragma_Argument_Associations ( 12097 Get_Rep_Pragma (TaskId, 12098 Name_Secondary_Stack_Size)))); 12099 12100 Stack_Size : Node_Id; 12101 12102 begin 12103 -- The secondary stack is defined inside the corresponding 12104 -- record. Therefore if the size of the stack is set by means 12105 -- of a discriminant, we must reference the discriminant of the 12106 -- corresponding record type. 12107 12108 if Nkind (Size_Expr) in N_Has_Entity 12109 and then Present (Discriminal_Link (Entity (Size_Expr))) 12110 then 12111 Stack_Size := 12112 New_Occurrence_Of 12113 (CR_Discriminant (Discriminal_Link (Entity (Size_Expr))), 12114 Loc); 12115 Set_Parent (Stack_Size, Parent (Size_Expr)); 12116 Set_Etype (Stack_Size, Etype (Size_Expr)); 12117 Set_Analyzed (Stack_Size); 12118 12119 else 12120 Stack_Size := New_Copy_Tree (Size_Expr); 12121 end if; 12122 12123 -- Create the secondary stack for the task 12124 12125 Decl_SS := 12126 Make_Component_Declaration (Loc, 12127 Defining_Identifier => 12128 Make_Defining_Identifier (Loc, Name_uSecondary_Stack), 12129 Component_Definition => 12130 Make_Component_Definition (Loc, 12131 Aliased_Present => True, 12132 Subtype_Indication => 12133 Make_Subtype_Indication (Loc, 12134 Subtype_Mark => 12135 New_Occurrence_Of (RTE (RE_SS_Stack), Loc), 12136 Constraint => 12137 Make_Index_Or_Discriminant_Constraint (Loc, 12138 Constraints => New_List ( 12139 Convert_To (RTE (RE_Size_Type), 12140 Stack_Size)))))); 12141 12142 Append_To (Cdecls, Decl_SS); 12143 end; 12144 end if; 12145 12146 -- Add components for entry families 12147 12148 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); 12149 12150 -- Add the _Priority component if a Interrupt_Priority or Priority rep 12151 -- item is present. 12152 12153 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then 12154 Append_To (Cdecls, 12155 Make_Component_Declaration (Loc, 12156 Defining_Identifier => 12157 Make_Defining_Identifier (Loc, Name_uPriority), 12158 Component_Definition => 12159 Make_Component_Definition (Loc, 12160 Aliased_Present => False, 12161 Subtype_Indication => 12162 New_Occurrence_Of (Standard_Integer, Loc)))); 12163 end if; 12164 12165 -- Add the _Size component if a Storage_Size pragma is present 12166 12167 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 12168 Append_To (Cdecls, 12169 Make_Component_Declaration (Loc, 12170 Defining_Identifier => 12171 Make_Defining_Identifier (Loc, Name_uSize), 12172 12173 Component_Definition => 12174 Make_Component_Definition (Loc, 12175 Aliased_Present => False, 12176 Subtype_Indication => 12177 New_Occurrence_Of (RTE (RE_Size_Type), Loc)), 12178 12179 Expression => 12180 Convert_To (RTE (RE_Size_Type), 12181 New_Copy_Tree ( 12182 Expression (First ( 12183 Pragma_Argument_Associations ( 12184 Get_Rep_Pragma (TaskId, Name_Storage_Size)))))))); 12185 end if; 12186 12187 -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size 12188 -- pragma is present. 12189 12190 if Has_Rep_Pragma 12191 (TaskId, Name_Secondary_Stack_Size, Check_Parents => False) 12192 then 12193 Append_To (Cdecls, 12194 Make_Component_Declaration (Loc, 12195 Defining_Identifier => 12196 Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size), 12197 12198 Component_Definition => 12199 Make_Component_Definition (Loc, 12200 Aliased_Present => False, 12201 Subtype_Indication => 12202 New_Occurrence_Of (RTE (RE_Size_Type), Loc)))); 12203 end if; 12204 12205 -- Add the _Task_Info component if a Task_Info pragma is present 12206 12207 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then 12208 Append_To (Cdecls, 12209 Make_Component_Declaration (Loc, 12210 Defining_Identifier => 12211 Make_Defining_Identifier (Loc, Name_uTask_Info), 12212 12213 Component_Definition => 12214 Make_Component_Definition (Loc, 12215 Aliased_Present => False, 12216 Subtype_Indication => 12217 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)), 12218 12219 Expression => New_Copy ( 12220 Expression (First ( 12221 Pragma_Argument_Associations ( 12222 Get_Rep_Pragma 12223 (TaskId, Name_Task_Info, Check_Parents => False))))))); 12224 end if; 12225 12226 -- Add the _CPU component if a CPU rep item is present 12227 12228 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then 12229 Append_To (Cdecls, 12230 Make_Component_Declaration (Loc, 12231 Defining_Identifier => 12232 Make_Defining_Identifier (Loc, Name_uCPU), 12233 12234 Component_Definition => 12235 Make_Component_Definition (Loc, 12236 Aliased_Present => False, 12237 Subtype_Indication => 12238 New_Occurrence_Of (RTE (RE_CPU_Range), Loc)))); 12239 end if; 12240 12241 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is 12242 -- present. If we are using a restricted run time this component will 12243 -- not be added (deadlines are not allowed by the Ravenscar profile), 12244 -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF 12245 -- profile). 12246 12247 if (not Restricted_Profile or else Task_Dispatching_Policy = 'E') 12248 and then Present (Taskdef) 12249 and then Has_Relative_Deadline_Pragma (Taskdef) 12250 then 12251 Append_To (Cdecls, 12252 Make_Component_Declaration (Loc, 12253 Defining_Identifier => 12254 Make_Defining_Identifier (Loc, Name_uRelative_Deadline), 12255 12256 Component_Definition => 12257 Make_Component_Definition (Loc, 12258 Aliased_Present => False, 12259 Subtype_Indication => 12260 New_Occurrence_Of (RTE (RE_Time_Span), Loc)), 12261 12262 Expression => 12263 Convert_To (RTE (RE_Time_Span), 12264 New_Copy_Tree ( 12265 Expression (First ( 12266 Pragma_Argument_Associations ( 12267 Get_Relative_Deadline_Pragma (Taskdef)))))))); 12268 end if; 12269 12270 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep 12271 -- item is present. If we are using a restricted run time this component 12272 -- will not be added (dispatching domains are not allowed by the 12273 -- Ravenscar profile). 12274 12275 if not Restricted_Profile 12276 and then 12277 Has_Rep_Item 12278 (TaskId, Name_Dispatching_Domain, Check_Parents => False) 12279 then 12280 Append_To (Cdecls, 12281 Make_Component_Declaration (Loc, 12282 Defining_Identifier => 12283 Make_Defining_Identifier (Loc, Name_uDispatching_Domain), 12284 12285 Component_Definition => 12286 Make_Component_Definition (Loc, 12287 Aliased_Present => False, 12288 Subtype_Indication => 12289 New_Occurrence_Of 12290 (RTE (RE_Dispatching_Domain_Access), Loc)))); 12291 end if; 12292 12293 Insert_After (Size_Decl, Rec_Decl); 12294 12295 -- Analyze the record declaration immediately after construction, 12296 -- because the initialization procedure is needed for single task 12297 -- declarations before the next entity is analyzed. 12298 12299 Analyze (Rec_Decl); 12300 12301 -- Create the declaration of the task body procedure 12302 12303 Proc_Spec := Build_Task_Proc_Specification (Tasktyp); 12304 Body_Decl := 12305 Make_Subprogram_Declaration (Loc, 12306 Specification => Proc_Spec); 12307 Set_Is_Task_Body_Procedure (Body_Decl); 12308 12309 Insert_After (Rec_Decl, Body_Decl); 12310 12311 -- The subprogram does not comes from source, so we have to indicate the 12312 -- need for debugging information explicitly. 12313 12314 if Comes_From_Source (Original_Node (N)) then 12315 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec)); 12316 end if; 12317 12318 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before 12319 -- the corresponding record has been frozen. 12320 12321 if Ada_Version >= Ada_2005 then 12322 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl); 12323 end if; 12324 12325 -- Ada 2005 (AI-345): We must defer freezing to allow further 12326 -- declaration of primitive subprograms covering task interfaces 12327 12328 if Ada_Version <= Ada_95 then 12329 12330 -- Now we can freeze the corresponding record. This needs manually 12331 -- freezing, since it is really part of the task type, and the task 12332 -- type is frozen at this stage. We of course need the initialization 12333 -- procedure for this corresponding record type and we won't get it 12334 -- in time if we don't freeze now. 12335 12336 declare 12337 L : constant List_Id := Freeze_Entity (Rec_Ent, N); 12338 begin 12339 if Is_Non_Empty_List (L) then 12340 Insert_List_After (Body_Decl, L); 12341 end if; 12342 end; 12343 end if; 12344 12345 -- Complete the expansion of access types to the current task type, if 12346 -- any were declared. 12347 12348 Expand_Previous_Access_Type (Tasktyp); 12349 12350 -- Create wrappers for entries that have contract cases, preconditions 12351 -- and postconditions. 12352 12353 declare 12354 Ent : Entity_Id; 12355 12356 begin 12357 Ent := First_Entity (Tasktyp); 12358 while Present (Ent) loop 12359 if Ekind_In (Ent, E_Entry, E_Entry_Family) then 12360 Build_Contract_Wrapper (Ent, N); 12361 end if; 12362 12363 Next_Entity (Ent); 12364 end loop; 12365 end; 12366 end Expand_N_Task_Type_Declaration; 12367 12368 ------------------------------- 12369 -- Expand_N_Timed_Entry_Call -- 12370 ------------------------------- 12371 12372 -- A timed entry call in normal case is not implemented using ATC mechanism 12373 -- anymore for efficiency reason. 12374 12375 -- select 12376 -- T.E; 12377 -- S1; 12378 -- or 12379 -- delay D; 12380 -- S2; 12381 -- end select; 12382 12383 -- is expanded as follows: 12384 12385 -- 1) When T.E is a task entry_call; 12386 12387 -- declare 12388 -- B : Boolean; 12389 -- X : Task_Entry_Index := <entry index>; 12390 -- DX : Duration := To_Duration (D); 12391 -- M : Delay_Mode := <discriminant>; 12392 -- P : parms := (parm, parm, parm); 12393 12394 -- begin 12395 -- Timed_Protected_Entry_Call 12396 -- (<acceptor-task>, X, P'Address, DX, M, B); 12397 -- if B then 12398 -- S1; 12399 -- else 12400 -- S2; 12401 -- end if; 12402 -- end; 12403 12404 -- 2) When T.E is a protected entry_call; 12405 12406 -- declare 12407 -- B : Boolean; 12408 -- X : Protected_Entry_Index := <entry index>; 12409 -- DX : Duration := To_Duration (D); 12410 -- M : Delay_Mode := <discriminant>; 12411 -- P : parms := (parm, parm, parm); 12412 12413 -- begin 12414 -- Timed_Protected_Entry_Call 12415 -- (<object>'unchecked_access, X, P'Address, DX, M, B); 12416 -- if B then 12417 -- S1; 12418 -- else 12419 -- S2; 12420 -- end if; 12421 -- end; 12422 12423 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there 12424 -- is no delay and the triggering statements are executed. We first 12425 -- determine the kind of the triggering call and then execute a 12426 -- synchronized operation or a direct call. 12427 12428 -- declare 12429 -- B : Boolean := False; 12430 -- C : Ada.Tags.Prim_Op_Kind; 12431 -- DX : Duration := To_Duration (D) 12432 -- K : Ada.Tags.Tagged_Kind := 12433 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 12434 -- M : Integer :=...; 12435 -- P : Parameters := (Param1 .. ParamN); 12436 -- S : Integer; 12437 12438 -- begin 12439 -- if K = Ada.Tags.TK_Limited_Tagged 12440 -- or else K = Ada.Tags.TK_Tagged 12441 -- then 12442 -- <dispatching-call>; 12443 -- B := True; 12444 12445 -- else 12446 -- S := 12447 -- Ada.Tags.Get_Offset_Index 12448 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 12449 12450 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B); 12451 12452 -- if C = POK_Protected_Entry 12453 -- or else C = POK_Task_Entry 12454 -- then 12455 -- Param1 := P.Param1; 12456 -- ... 12457 -- ParamN := P.ParamN; 12458 -- end if; 12459 12460 -- if B then 12461 -- if C = POK_Procedure 12462 -- or else C = POK_Protected_Procedure 12463 -- or else C = POK_Task_Procedure 12464 -- then 12465 -- <dispatching-call>; 12466 -- end if; 12467 -- end if; 12468 -- end if; 12469 12470 -- if B then 12471 -- <triggering-statements> 12472 -- else 12473 -- <timed-statements> 12474 -- end if; 12475 -- end; 12476 12477 -- The triggering statement and the sequence of timed statements have not 12478 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain 12479 -- global references if within an instantiation. 12480 12481 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is 12482 Loc : constant Source_Ptr := Sloc (N); 12483 12484 Actuals : List_Id; 12485 Blk_Typ : Entity_Id; 12486 Call : Node_Id; 12487 Call_Ent : Entity_Id; 12488 Conc_Typ_Stmts : List_Id; 12489 Concval : Node_Id := Empty; -- init to avoid warning 12490 D_Alt : constant Node_Id := Delay_Alternative (N); 12491 D_Conv : Node_Id; 12492 D_Disc : Node_Id; 12493 D_Stat : Node_Id := Delay_Statement (D_Alt); 12494 D_Stats : List_Id; 12495 D_Type : Entity_Id; 12496 Decls : List_Id; 12497 Dummy : Node_Id; 12498 E_Alt : constant Node_Id := Entry_Call_Alternative (N); 12499 E_Call : Node_Id := Entry_Call_Statement (E_Alt); 12500 E_Stats : List_Id; 12501 Ename : Node_Id; 12502 Formals : List_Id; 12503 Index : Node_Id; 12504 Is_Disp_Select : Boolean; 12505 Lim_Typ_Stmts : List_Id; 12506 N_Stats : List_Id; 12507 Obj : Entity_Id; 12508 Param : Node_Id; 12509 Params : List_Id; 12510 Stmt : Node_Id; 12511 Stmts : List_Id; 12512 Unpack : List_Id; 12513 12514 B : Entity_Id; -- Call status flag 12515 C : Entity_Id; -- Call kind 12516 D : Entity_Id; -- Delay 12517 K : Entity_Id; -- Tagged kind 12518 M : Entity_Id; -- Delay mode 12519 P : Entity_Id; -- Parameter block 12520 S : Entity_Id; -- Primitive operation slot 12521 12522 -- Start of processing for Expand_N_Timed_Entry_Call 12523 12524 begin 12525 -- Under the Ravenscar profile, timed entry calls are excluded. An error 12526 -- was already reported on spec, so do not attempt to expand the call. 12527 12528 if Restriction_Active (No_Select_Statements) then 12529 return; 12530 end if; 12531 12532 Process_Statements_For_Controlled_Objects (E_Alt); 12533 Process_Statements_For_Controlled_Objects (D_Alt); 12534 12535 Ensure_Statement_Present (Sloc (D_Stat), D_Alt); 12536 12537 -- Retrieve E_Stats and D_Stats now because the finalization machinery 12538 -- may wrap them in blocks. 12539 12540 E_Stats := Statements (E_Alt); 12541 D_Stats := Statements (D_Alt); 12542 12543 -- The arguments in the call may require dynamic allocation, and the 12544 -- call statement may have been transformed into a block. The block 12545 -- may contain additional declarations for internal entities, and the 12546 -- original call is found by sequential search. 12547 12548 if Nkind (E_Call) = N_Block_Statement then 12549 E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); 12550 while not Nkind_In (E_Call, N_Procedure_Call_Statement, 12551 N_Entry_Call_Statement) 12552 loop 12553 Next (E_Call); 12554 end loop; 12555 end if; 12556 12557 Is_Disp_Select := 12558 Ada_Version >= Ada_2005 12559 and then Nkind (E_Call) = N_Procedure_Call_Statement; 12560 12561 if Is_Disp_Select then 12562 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals); 12563 Decls := New_List; 12564 12565 Stmts := New_List; 12566 12567 -- Generate: 12568 -- B : Boolean := False; 12569 12570 B := Build_B (Loc, Decls); 12571 12572 -- Generate: 12573 -- C : Ada.Tags.Prim_Op_Kind; 12574 12575 C := Build_C (Loc, Decls); 12576 12577 -- Because the analysis of all statements was disabled, manually 12578 -- analyze the delay statement. 12579 12580 Analyze (D_Stat); 12581 D_Stat := Original_Node (D_Stat); 12582 12583 else 12584 -- Build an entry call using Simple_Entry_Call 12585 12586 Extract_Entry (E_Call, Concval, Ename, Index); 12587 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); 12588 12589 Decls := Declarations (E_Call); 12590 Stmts := Statements (Handled_Statement_Sequence (E_Call)); 12591 12592 if No (Decls) then 12593 Decls := New_List; 12594 end if; 12595 12596 -- Generate: 12597 -- B : Boolean; 12598 12599 B := Make_Defining_Identifier (Loc, Name_uB); 12600 12601 Prepend_To (Decls, 12602 Make_Object_Declaration (Loc, 12603 Defining_Identifier => B, 12604 Object_Definition => 12605 New_Occurrence_Of (Standard_Boolean, Loc))); 12606 end if; 12607 12608 -- Duration and mode processing 12609 12610 D_Type := Base_Type (Etype (Expression (D_Stat))); 12611 12612 -- Use the type of the delay expression (Calendar or Real_Time) to 12613 -- generate the appropriate conversion. 12614 12615 if Nkind (D_Stat) = N_Delay_Relative_Statement then 12616 D_Disc := Make_Integer_Literal (Loc, 0); 12617 D_Conv := Relocate_Node (Expression (D_Stat)); 12618 12619 elsif Is_RTE (D_Type, RO_CA_Time) then 12620 D_Disc := Make_Integer_Literal (Loc, 1); 12621 D_Conv := 12622 Make_Function_Call (Loc, 12623 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 12624 Parameter_Associations => 12625 New_List (New_Copy (Expression (D_Stat)))); 12626 12627 else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); 12628 D_Disc := Make_Integer_Literal (Loc, 2); 12629 D_Conv := 12630 Make_Function_Call (Loc, 12631 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 12632 Parameter_Associations => 12633 New_List (New_Copy (Expression (D_Stat)))); 12634 end if; 12635 12636 D := Make_Temporary (Loc, 'D'); 12637 12638 -- Generate: 12639 -- D : Duration; 12640 12641 Append_To (Decls, 12642 Make_Object_Declaration (Loc, 12643 Defining_Identifier => D, 12644 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc))); 12645 12646 M := Make_Temporary (Loc, 'M'); 12647 12648 -- Generate: 12649 -- M : Integer := (0 | 1 | 2); 12650 12651 Append_To (Decls, 12652 Make_Object_Declaration (Loc, 12653 Defining_Identifier => M, 12654 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 12655 Expression => D_Disc)); 12656 12657 -- Do the assignment at this stage only because the evaluation of the 12658 -- expression must not occur earlier (see ACVC C97302A). 12659 12660 Append_To (Stmts, 12661 Make_Assignment_Statement (Loc, 12662 Name => New_Occurrence_Of (D, Loc), 12663 Expression => D_Conv)); 12664 12665 -- Parameter block processing 12666 12667 -- Manually create the parameter block for dispatching calls. In the 12668 -- case of entries, the block has already been created during the call 12669 -- to Build_Simple_Entry_Call. 12670 12671 if Is_Disp_Select then 12672 12673 -- Tagged kind processing, generate: 12674 -- K : Ada.Tags.Tagged_Kind := 12675 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>)); 12676 12677 K := Build_K (Loc, Decls, Obj); 12678 12679 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 12680 P := 12681 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 12682 12683 -- Dispatch table slot processing, generate: 12684 -- S : Integer; 12685 12686 S := Build_S (Loc, Decls); 12687 12688 -- Generate: 12689 -- S := Ada.Tags.Get_Offset_Index 12690 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 12691 12692 Conc_Typ_Stmts := 12693 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 12694 12695 -- Generate: 12696 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B); 12697 12698 -- where Obj is the controlling formal parameter, S is the dispatch 12699 -- table slot number of the dispatching operation, P is the wrapped 12700 -- parameter block, D is the duration, M is the duration mode, C is 12701 -- the call kind and B is the call status. 12702 12703 Params := New_List; 12704 12705 Append_To (Params, New_Copy_Tree (Obj)); 12706 Append_To (Params, New_Occurrence_Of (S, Loc)); 12707 Append_To (Params, 12708 Make_Attribute_Reference (Loc, 12709 Prefix => New_Occurrence_Of (P, Loc), 12710 Attribute_Name => Name_Address)); 12711 Append_To (Params, New_Occurrence_Of (D, Loc)); 12712 Append_To (Params, New_Occurrence_Of (M, Loc)); 12713 Append_To (Params, New_Occurrence_Of (C, Loc)); 12714 Append_To (Params, New_Occurrence_Of (B, Loc)); 12715 12716 Append_To (Conc_Typ_Stmts, 12717 Make_Procedure_Call_Statement (Loc, 12718 Name => 12719 New_Occurrence_Of 12720 (Find_Prim_Op 12721 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc), 12722 Parameter_Associations => Params)); 12723 12724 -- Generate: 12725 -- if C = POK_Protected_Entry 12726 -- or else C = POK_Task_Entry 12727 -- then 12728 -- Param1 := P.Param1; 12729 -- ... 12730 -- ParamN := P.ParamN; 12731 -- end if; 12732 12733 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 12734 12735 -- Generate the if statement only when the packed parameters need 12736 -- explicit assignments to their corresponding actuals. 12737 12738 if Present (Unpack) then 12739 Append_To (Conc_Typ_Stmts, 12740 Make_Implicit_If_Statement (N, 12741 12742 Condition => 12743 Make_Or_Else (Loc, 12744 Left_Opnd => 12745 Make_Op_Eq (Loc, 12746 Left_Opnd => New_Occurrence_Of (C, Loc), 12747 Right_Opnd => 12748 New_Occurrence_Of 12749 (RTE (RE_POK_Protected_Entry), Loc)), 12750 12751 Right_Opnd => 12752 Make_Op_Eq (Loc, 12753 Left_Opnd => New_Occurrence_Of (C, Loc), 12754 Right_Opnd => 12755 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 12756 12757 Then_Statements => Unpack)); 12758 end if; 12759 12760 -- Generate: 12761 12762 -- if B then 12763 -- if C = POK_Procedure 12764 -- or else C = POK_Protected_Procedure 12765 -- or else C = POK_Task_Procedure 12766 -- then 12767 -- <dispatching-call> 12768 -- end if; 12769 -- end if; 12770 12771 N_Stats := New_List ( 12772 Make_Implicit_If_Statement (N, 12773 Condition => 12774 Make_Or_Else (Loc, 12775 Left_Opnd => 12776 Make_Op_Eq (Loc, 12777 Left_Opnd => New_Occurrence_Of (C, Loc), 12778 Right_Opnd => 12779 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 12780 12781 Right_Opnd => 12782 Make_Or_Else (Loc, 12783 Left_Opnd => 12784 Make_Op_Eq (Loc, 12785 Left_Opnd => New_Occurrence_Of (C, Loc), 12786 Right_Opnd => 12787 New_Occurrence_Of (RTE ( 12788 RE_POK_Protected_Procedure), Loc)), 12789 Right_Opnd => 12790 Make_Op_Eq (Loc, 12791 Left_Opnd => New_Occurrence_Of (C, Loc), 12792 Right_Opnd => 12793 New_Occurrence_Of 12794 (RTE (RE_POK_Task_Procedure), Loc)))), 12795 12796 Then_Statements => New_List (E_Call))); 12797 12798 Append_To (Conc_Typ_Stmts, 12799 Make_Implicit_If_Statement (N, 12800 Condition => New_Occurrence_Of (B, Loc), 12801 Then_Statements => N_Stats)); 12802 12803 -- Generate: 12804 -- <dispatching-call>; 12805 -- B := True; 12806 12807 Lim_Typ_Stmts := 12808 New_List (New_Copy_Tree (E_Call), 12809 Make_Assignment_Statement (Loc, 12810 Name => New_Occurrence_Of (B, Loc), 12811 Expression => New_Occurrence_Of (Standard_True, Loc))); 12812 12813 -- Generate: 12814 -- if K = Ada.Tags.TK_Limited_Tagged 12815 -- or else K = Ada.Tags.TK_Tagged 12816 -- then 12817 -- Lim_Typ_Stmts 12818 -- else 12819 -- Conc_Typ_Stmts 12820 -- end if; 12821 12822 Append_To (Stmts, 12823 Make_Implicit_If_Statement (N, 12824 Condition => Build_Dispatching_Tag_Check (K, N), 12825 Then_Statements => Lim_Typ_Stmts, 12826 Else_Statements => Conc_Typ_Stmts)); 12827 12828 -- Generate: 12829 12830 -- if B then 12831 -- <triggering-statements> 12832 -- else 12833 -- <timed-statements> 12834 -- end if; 12835 12836 Append_To (Stmts, 12837 Make_Implicit_If_Statement (N, 12838 Condition => New_Occurrence_Of (B, Loc), 12839 Then_Statements => E_Stats, 12840 Else_Statements => D_Stats)); 12841 12842 else 12843 -- Simple case of a nondispatching trigger. Skip assignments to 12844 -- temporaries created for in-out parameters. 12845 12846 -- This makes unwarranted assumptions about the shape of the expanded 12847 -- tree for the call, and should be cleaned up ??? 12848 12849 Stmt := First (Stmts); 12850 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 12851 Next (Stmt); 12852 end loop; 12853 12854 -- Do the assignment at this stage only because the evaluation 12855 -- of the expression must not occur earlier (see ACVC C97302A). 12856 12857 Insert_Before (Stmt, 12858 Make_Assignment_Statement (Loc, 12859 Name => New_Occurrence_Of (D, Loc), 12860 Expression => D_Conv)); 12861 12862 Call := Stmt; 12863 Params := Parameter_Associations (Call); 12864 12865 -- For a protected type, we build a Timed_Protected_Entry_Call 12866 12867 if Is_Protected_Type (Etype (Concval)) then 12868 12869 -- Create a new call statement 12870 12871 Param := First (Params); 12872 while Present (Param) 12873 and then not Is_RTE (Etype (Param), RE_Call_Modes) 12874 loop 12875 Next (Param); 12876 end loop; 12877 12878 Dummy := Remove_Next (Next (Param)); 12879 12880 -- Remove garbage is following the Cancel_Param if present 12881 12882 Dummy := Next (Param); 12883 12884 -- Remove the mode of the Protected_Entry_Call call, then remove 12885 -- the Communication_Block of the Protected_Entry_Call call, and 12886 -- finally add Duration and a Delay_Mode parameter 12887 12888 pragma Assert (Present (Param)); 12889 Rewrite (Param, New_Occurrence_Of (D, Loc)); 12890 12891 Rewrite (Dummy, New_Occurrence_Of (M, Loc)); 12892 12893 -- Add a Boolean flag for successful entry call 12894 12895 Append_To (Params, New_Occurrence_Of (B, Loc)); 12896 12897 case Corresponding_Runtime_Package (Etype (Concval)) is 12898 when System_Tasking_Protected_Objects_Entries => 12899 Rewrite (Call, 12900 Make_Procedure_Call_Statement (Loc, 12901 Name => 12902 New_Occurrence_Of 12903 (RTE (RE_Timed_Protected_Entry_Call), Loc), 12904 Parameter_Associations => Params)); 12905 12906 when others => 12907 raise Program_Error; 12908 end case; 12909 12910 -- For the task case, build a Timed_Task_Entry_Call 12911 12912 else 12913 -- Create a new call statement 12914 12915 Append_To (Params, New_Occurrence_Of (D, Loc)); 12916 Append_To (Params, New_Occurrence_Of (M, Loc)); 12917 Append_To (Params, New_Occurrence_Of (B, Loc)); 12918 12919 Rewrite (Call, 12920 Make_Procedure_Call_Statement (Loc, 12921 Name => 12922 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc), 12923 Parameter_Associations => Params)); 12924 end if; 12925 12926 Append_To (Stmts, 12927 Make_Implicit_If_Statement (N, 12928 Condition => New_Occurrence_Of (B, Loc), 12929 Then_Statements => E_Stats, 12930 Else_Statements => D_Stats)); 12931 end if; 12932 12933 Rewrite (N, 12934 Make_Block_Statement (Loc, 12935 Declarations => Decls, 12936 Handled_Statement_Sequence => 12937 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 12938 12939 Analyze (N); 12940 12941 -- Some items in Decls used to be in the N_Block in E_Call that 12942 -- is constructed in Expand_Entry_Call, and are now in the new 12943 -- Block into which N has been rewritten. Adjust their scopes 12944 -- to reflect that. 12945 12946 if Nkind (E_Call) = N_Block_Statement then 12947 Obj := First_Entity (Entity (Identifier (E_Call))); 12948 while Present (Obj) loop 12949 Set_Scope (Obj, Entity (Identifier (N))); 12950 Next_Entity (Obj); 12951 end loop; 12952 end if; 12953 12954 Reset_Scopes_To (N, Entity (Identifier (N))); 12955 end Expand_N_Timed_Entry_Call; 12956 12957 ---------------------------------------- 12958 -- Expand_Protected_Body_Declarations -- 12959 ---------------------------------------- 12960 12961 procedure Expand_Protected_Body_Declarations 12962 (N : Node_Id; 12963 Spec_Id : Entity_Id) 12964 is 12965 begin 12966 if No_Run_Time_Mode then 12967 Error_Msg_CRT ("protected body", N); 12968 return; 12969 12970 elsif Expander_Active then 12971 12972 -- Associate discriminals with the first subprogram or entry body to 12973 -- be expanded. 12974 12975 if Present (First_Protected_Operation (Declarations (N))) then 12976 Set_Discriminals (Parent (Spec_Id)); 12977 end if; 12978 end if; 12979 end Expand_Protected_Body_Declarations; 12980 12981 ------------------------- 12982 -- External_Subprogram -- 12983 ------------------------- 12984 12985 function External_Subprogram (E : Entity_Id) return Entity_Id is 12986 Subp : constant Entity_Id := Protected_Body_Subprogram (E); 12987 12988 begin 12989 -- The internal and external subprograms follow each other on the entity 12990 -- chain. Note that previously private operations had no separate 12991 -- external subprogram. We now create one in all cases, because a 12992 -- private operation may actually appear in an external call, through 12993 -- a 'Access reference used for a callback. 12994 12995 -- If the operation is a function that returns an anonymous access type, 12996 -- the corresponding itype appears before the operation, and must be 12997 -- skipped. 12998 12999 -- This mechanism is fragile, there should be a real link between the 13000 -- two versions of the operation, but there is no place to put it ??? 13001 13002 if Is_Access_Type (Next_Entity (Subp)) then 13003 return Next_Entity (Next_Entity (Subp)); 13004 else 13005 return Next_Entity (Subp); 13006 end if; 13007 end External_Subprogram; 13008 13009 ------------------------------ 13010 -- Extract_Dispatching_Call -- 13011 ------------------------------ 13012 13013 procedure Extract_Dispatching_Call 13014 (N : Node_Id; 13015 Call_Ent : out Entity_Id; 13016 Object : out Entity_Id; 13017 Actuals : out List_Id; 13018 Formals : out List_Id) 13019 is 13020 Call_Nam : Node_Id; 13021 13022 begin 13023 pragma Assert (Nkind (N) = N_Procedure_Call_Statement); 13024 13025 if Present (Original_Node (N)) then 13026 Call_Nam := Name (Original_Node (N)); 13027 else 13028 Call_Nam := Name (N); 13029 end if; 13030 13031 -- Retrieve the name of the dispatching procedure. It contains the 13032 -- dispatch table slot number. 13033 13034 loop 13035 case Nkind (Call_Nam) is 13036 when N_Identifier => 13037 exit; 13038 13039 when N_Selected_Component => 13040 Call_Nam := Selector_Name (Call_Nam); 13041 13042 when others => 13043 raise Program_Error; 13044 end case; 13045 end loop; 13046 13047 Actuals := Parameter_Associations (N); 13048 Call_Ent := Entity (Call_Nam); 13049 Formals := Parameter_Specifications (Parent (Call_Ent)); 13050 Object := First (Actuals); 13051 13052 if Present (Original_Node (Object)) then 13053 Object := Original_Node (Object); 13054 end if; 13055 13056 -- If the type of the dispatching object is an access type then return 13057 -- an explicit dereference of a copy of the object, and note that this 13058 -- is the controlling actual of the call. 13059 13060 if Is_Access_Type (Etype (Object)) then 13061 Object := 13062 Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object)); 13063 Analyze (Object); 13064 Set_Is_Controlling_Actual (Object); 13065 end if; 13066 end Extract_Dispatching_Call; 13067 13068 ------------------- 13069 -- Extract_Entry -- 13070 ------------------- 13071 13072 procedure Extract_Entry 13073 (N : Node_Id; 13074 Concval : out Node_Id; 13075 Ename : out Node_Id; 13076 Index : out Node_Id) 13077 is 13078 Nam : constant Node_Id := Name (N); 13079 13080 begin 13081 -- For a simple entry, the name is a selected component, with the 13082 -- prefix being the task value, and the selector being the entry. 13083 13084 if Nkind (Nam) = N_Selected_Component then 13085 Concval := Prefix (Nam); 13086 Ename := Selector_Name (Nam); 13087 Index := Empty; 13088 13089 -- For a member of an entry family, the name is an indexed component 13090 -- where the prefix is a selected component, whose prefix in turn is 13091 -- the task value, and whose selector is the entry family. The single 13092 -- expression in the expressions list of the indexed component is the 13093 -- subscript for the family. 13094 13095 else pragma Assert (Nkind (Nam) = N_Indexed_Component); 13096 Concval := Prefix (Prefix (Nam)); 13097 Ename := Selector_Name (Prefix (Nam)); 13098 Index := First (Expressions (Nam)); 13099 end if; 13100 13101 -- Through indirection, the type may actually be a limited view of a 13102 -- concurrent type. When compiling a call, the non-limited view of the 13103 -- type is visible. 13104 13105 if From_Limited_With (Etype (Concval)) then 13106 Set_Etype (Concval, Non_Limited_View (Etype (Concval))); 13107 end if; 13108 end Extract_Entry; 13109 13110 ------------------- 13111 -- Family_Offset -- 13112 ------------------- 13113 13114 function Family_Offset 13115 (Loc : Source_Ptr; 13116 Hi : Node_Id; 13117 Lo : Node_Id; 13118 Ttyp : Entity_Id; 13119 Cap : Boolean) return Node_Id 13120 is 13121 Ityp : Entity_Id; 13122 Real_Hi : Node_Id; 13123 Real_Lo : Node_Id; 13124 13125 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 13126 -- If one of the bounds is a reference to a discriminant, replace with 13127 -- corresponding discriminal of type. Within the body of a task retrieve 13128 -- the renamed discriminant by simple visibility, using its generated 13129 -- name. Within a protected object, find the original discriminant and 13130 -- replace it with the discriminal of the current protected operation. 13131 13132 ------------------------------ 13133 -- Convert_Discriminant_Ref -- 13134 ------------------------------ 13135 13136 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 13137 Loc : constant Source_Ptr := Sloc (Bound); 13138 B : Node_Id; 13139 D : Entity_Id; 13140 13141 begin 13142 if Is_Entity_Name (Bound) 13143 and then Ekind (Entity (Bound)) = E_Discriminant 13144 then 13145 if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then 13146 B := Make_Identifier (Loc, Chars (Entity (Bound))); 13147 Find_Direct_Name (B); 13148 13149 elsif Is_Protected_Type (Ttyp) then 13150 D := First_Discriminant (Ttyp); 13151 while Chars (D) /= Chars (Entity (Bound)) loop 13152 Next_Discriminant (D); 13153 end loop; 13154 13155 B := New_Occurrence_Of (Discriminal (D), Loc); 13156 13157 else 13158 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); 13159 end if; 13160 13161 elsif Nkind (Bound) = N_Attribute_Reference then 13162 return Bound; 13163 13164 else 13165 B := New_Copy_Tree (Bound); 13166 end if; 13167 13168 return 13169 Make_Attribute_Reference (Loc, 13170 Attribute_Name => Name_Pos, 13171 Prefix => New_Occurrence_Of (Etype (Bound), Loc), 13172 Expressions => New_List (B)); 13173 end Convert_Discriminant_Ref; 13174 13175 -- Start of processing for Family_Offset 13176 13177 begin 13178 Real_Hi := Convert_Discriminant_Ref (Hi); 13179 Real_Lo := Convert_Discriminant_Ref (Lo); 13180 13181 if Cap then 13182 if Is_Task_Type (Ttyp) then 13183 Ityp := RTE (RE_Task_Entry_Index); 13184 else 13185 Ityp := RTE (RE_Protected_Entry_Index); 13186 end if; 13187 13188 Real_Hi := 13189 Make_Attribute_Reference (Loc, 13190 Prefix => New_Occurrence_Of (Ityp, Loc), 13191 Attribute_Name => Name_Min, 13192 Expressions => New_List ( 13193 Real_Hi, 13194 Make_Integer_Literal (Loc, Entry_Family_Bound - 1))); 13195 13196 Real_Lo := 13197 Make_Attribute_Reference (Loc, 13198 Prefix => New_Occurrence_Of (Ityp, Loc), 13199 Attribute_Name => Name_Max, 13200 Expressions => New_List ( 13201 Real_Lo, 13202 Make_Integer_Literal (Loc, -Entry_Family_Bound))); 13203 end if; 13204 13205 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo); 13206 end Family_Offset; 13207 13208 ----------------- 13209 -- Family_Size -- 13210 ----------------- 13211 13212 function Family_Size 13213 (Loc : Source_Ptr; 13214 Hi : Node_Id; 13215 Lo : Node_Id; 13216 Ttyp : Entity_Id; 13217 Cap : Boolean) return Node_Id 13218 is 13219 Ityp : Entity_Id; 13220 13221 begin 13222 if Is_Task_Type (Ttyp) then 13223 Ityp := RTE (RE_Task_Entry_Index); 13224 else 13225 Ityp := RTE (RE_Protected_Entry_Index); 13226 end if; 13227 13228 return 13229 Make_Attribute_Reference (Loc, 13230 Prefix => New_Occurrence_Of (Ityp, Loc), 13231 Attribute_Name => Name_Max, 13232 Expressions => New_List ( 13233 Make_Op_Add (Loc, 13234 Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap), 13235 Right_Opnd => Make_Integer_Literal (Loc, 1)), 13236 Make_Integer_Literal (Loc, 0))); 13237 end Family_Size; 13238 13239 ---------------------------- 13240 -- Find_Enclosing_Context -- 13241 ---------------------------- 13242 13243 procedure Find_Enclosing_Context 13244 (N : Node_Id; 13245 Context : out Node_Id; 13246 Context_Id : out Entity_Id; 13247 Context_Decls : out List_Id) 13248 is 13249 begin 13250 -- Traverse the parent chain looking for an enclosing body, block, 13251 -- package or return statement. 13252 13253 Context := Parent (N); 13254 while Present (Context) loop 13255 if Nkind_In (Context, N_Entry_Body, 13256 N_Extended_Return_Statement, 13257 N_Package_Body, 13258 N_Package_Declaration, 13259 N_Subprogram_Body, 13260 N_Task_Body) 13261 then 13262 exit; 13263 13264 -- Do not consider block created to protect a list of statements with 13265 -- an Abort_Defer / Abort_Undefer_Direct pair. 13266 13267 elsif Nkind (Context) = N_Block_Statement 13268 and then not Is_Abort_Block (Context) 13269 then 13270 exit; 13271 end if; 13272 13273 Context := Parent (Context); 13274 end loop; 13275 13276 pragma Assert (Present (Context)); 13277 13278 -- Extract the constituents of the context 13279 13280 if Nkind (Context) = N_Extended_Return_Statement then 13281 Context_Decls := Return_Object_Declarations (Context); 13282 Context_Id := Return_Statement_Entity (Context); 13283 13284 -- Package declarations and bodies use a common library-level activation 13285 -- chain or task master, therefore return the package declaration as the 13286 -- proper carrier for the appropriate flag. 13287 13288 elsif Nkind (Context) = N_Package_Body then 13289 Context_Decls := Declarations (Context); 13290 Context_Id := Corresponding_Spec (Context); 13291 Context := Parent (Context_Id); 13292 13293 if Nkind (Context) = N_Defining_Program_Unit_Name then 13294 Context := Parent (Parent (Context)); 13295 else 13296 Context := Parent (Context); 13297 end if; 13298 13299 elsif Nkind (Context) = N_Package_Declaration then 13300 Context_Decls := Visible_Declarations (Specification (Context)); 13301 Context_Id := Defining_Unit_Name (Specification (Context)); 13302 13303 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13304 Context_Id := Defining_Identifier (Context_Id); 13305 end if; 13306 13307 else 13308 if Nkind (Context) = N_Block_Statement then 13309 Context_Id := Entity (Identifier (Context)); 13310 13311 elsif Nkind (Context) = N_Entry_Body then 13312 Context_Id := Defining_Identifier (Context); 13313 13314 elsif Nkind (Context) = N_Subprogram_Body then 13315 if Present (Corresponding_Spec (Context)) then 13316 Context_Id := Corresponding_Spec (Context); 13317 else 13318 Context_Id := Defining_Unit_Name (Specification (Context)); 13319 13320 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13321 Context_Id := Defining_Identifier (Context_Id); 13322 end if; 13323 end if; 13324 13325 elsif Nkind (Context) = N_Task_Body then 13326 Context_Id := Corresponding_Spec (Context); 13327 13328 else 13329 raise Program_Error; 13330 end if; 13331 13332 Context_Decls := Declarations (Context); 13333 end if; 13334 13335 pragma Assert (Present (Context_Id)); 13336 pragma Assert (Present (Context_Decls)); 13337 end Find_Enclosing_Context; 13338 13339 ----------------------- 13340 -- Find_Master_Scope -- 13341 ----------------------- 13342 13343 function Find_Master_Scope (E : Entity_Id) return Entity_Id is 13344 S : Entity_Id; 13345 13346 begin 13347 -- In Ada 2005, the master is the innermost enclosing scope that is not 13348 -- transient. If the enclosing block is the rewriting of a call or the 13349 -- scope is an extended return statement this is valid master. The 13350 -- master in an extended return is only used within the return, and is 13351 -- subsequently overwritten in Move_Activation_Chain, but it must exist 13352 -- now before that overwriting occurs. 13353 13354 S := Scope (E); 13355 13356 if Ada_Version >= Ada_2005 then 13357 while Is_Internal (S) loop 13358 if Nkind (Parent (S)) = N_Block_Statement 13359 and then 13360 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement 13361 then 13362 exit; 13363 13364 elsif Ekind (S) = E_Return_Statement then 13365 exit; 13366 13367 else 13368 S := Scope (S); 13369 end if; 13370 end loop; 13371 end if; 13372 13373 return S; 13374 end Find_Master_Scope; 13375 13376 ------------------------------- 13377 -- First_Protected_Operation -- 13378 ------------------------------- 13379 13380 function First_Protected_Operation (D : List_Id) return Node_Id is 13381 First_Op : Node_Id; 13382 13383 begin 13384 First_Op := First (D); 13385 while Present (First_Op) 13386 and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body) 13387 loop 13388 Next (First_Op); 13389 end loop; 13390 13391 return First_Op; 13392 end First_Protected_Operation; 13393 13394 --------------------------------------- 13395 -- Install_Private_Data_Declarations -- 13396 --------------------------------------- 13397 13398 procedure Install_Private_Data_Declarations 13399 (Loc : Source_Ptr; 13400 Spec_Id : Entity_Id; 13401 Conc_Typ : Entity_Id; 13402 Body_Nod : Node_Id; 13403 Decls : List_Id; 13404 Barrier : Boolean := False; 13405 Family : Boolean := False) 13406 is 13407 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ); 13408 Decl : Node_Id; 13409 Def : Node_Id; 13410 Insert_Node : Node_Id := Empty; 13411 Obj_Ent : Entity_Id; 13412 13413 procedure Add (Decl : Node_Id); 13414 -- Add a single declaration after Insert_Node. If this is the first 13415 -- addition, Decl is added to the front of Decls and it becomes the 13416 -- insertion node. 13417 13418 function Replace_Bound (Bound : Node_Id) return Node_Id; 13419 -- The bounds of an entry index may depend on discriminants, create a 13420 -- reference to the corresponding prival. Otherwise return a duplicate 13421 -- of the original bound. 13422 13423 --------- 13424 -- Add -- 13425 --------- 13426 13427 procedure Add (Decl : Node_Id) is 13428 begin 13429 if No (Insert_Node) then 13430 Prepend_To (Decls, Decl); 13431 else 13432 Insert_After (Insert_Node, Decl); 13433 end if; 13434 13435 Insert_Node := Decl; 13436 end Add; 13437 13438 ------------------- 13439 -- Replace_Bound -- 13440 ------------------- 13441 13442 function Replace_Bound (Bound : Node_Id) return Node_Id is 13443 begin 13444 if Nkind (Bound) = N_Identifier 13445 and then Is_Discriminal (Entity (Bound)) 13446 then 13447 return Make_Identifier (Loc, Chars (Entity (Bound))); 13448 else 13449 return Duplicate_Subexpr (Bound); 13450 end if; 13451 end Replace_Bound; 13452 13453 -- Start of processing for Install_Private_Data_Declarations 13454 13455 begin 13456 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote 13457 -- formal parameter _O, _object or _task depending on the context. 13458 13459 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ); 13460 13461 -- Special processing of _O for barrier functions, protected entries 13462 -- and families. 13463 13464 if Barrier 13465 or else 13466 (Is_Protected 13467 and then 13468 (Ekind (Spec_Id) = E_Entry 13469 or else Ekind (Spec_Id) = E_Entry_Family)) 13470 then 13471 declare 13472 Conc_Rec : constant Entity_Id := 13473 Corresponding_Record_Type (Conc_Typ); 13474 Typ_Id : constant Entity_Id := 13475 Make_Defining_Identifier (Loc, 13476 New_External_Name (Chars (Conc_Rec), 'P')); 13477 begin 13478 -- Generate: 13479 -- type prot_typVP is access prot_typV; 13480 13481 Decl := 13482 Make_Full_Type_Declaration (Loc, 13483 Defining_Identifier => Typ_Id, 13484 Type_Definition => 13485 Make_Access_To_Object_Definition (Loc, 13486 Subtype_Indication => 13487 New_Occurrence_Of (Conc_Rec, Loc))); 13488 Add (Decl); 13489 13490 -- Generate: 13491 -- _object : prot_typVP := prot_typV (_O); 13492 13493 Decl := 13494 Make_Object_Declaration (Loc, 13495 Defining_Identifier => 13496 Make_Defining_Identifier (Loc, Name_uObject), 13497 Object_Definition => New_Occurrence_Of (Typ_Id, Loc), 13498 Expression => 13499 Unchecked_Convert_To (Typ_Id, 13500 New_Occurrence_Of (Obj_Ent, Loc))); 13501 Add (Decl); 13502 13503 -- Set the reference to the concurrent object 13504 13505 Obj_Ent := Defining_Identifier (Decl); 13506 end; 13507 end if; 13508 13509 -- Step 2: Create the Protection object and build its declaration for 13510 -- any protected entry (family) of subprogram. Note for the lock-free 13511 -- implementation, the Protection object is not needed anymore. 13512 13513 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then 13514 declare 13515 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); 13516 Prot_Typ : RE_Id; 13517 13518 begin 13519 Set_Protection_Object (Spec_Id, Prot_Ent); 13520 13521 -- Determine the proper protection type 13522 13523 if Has_Attach_Handler (Conc_Typ) 13524 and then not Restricted_Profile 13525 then 13526 Prot_Typ := RE_Static_Interrupt_Protection; 13527 13528 elsif Has_Interrupt_Handler (Conc_Typ) 13529 and then not Restriction_Active (No_Dynamic_Attachment) 13530 then 13531 Prot_Typ := RE_Dynamic_Interrupt_Protection; 13532 13533 else 13534 case Corresponding_Runtime_Package (Conc_Typ) is 13535 when System_Tasking_Protected_Objects_Entries => 13536 Prot_Typ := RE_Protection_Entries; 13537 13538 when System_Tasking_Protected_Objects_Single_Entry => 13539 Prot_Typ := RE_Protection_Entry; 13540 13541 when System_Tasking_Protected_Objects => 13542 Prot_Typ := RE_Protection; 13543 13544 when others => 13545 raise Program_Error; 13546 end case; 13547 end if; 13548 13549 -- Generate: 13550 -- conc_typR : protection_typ renames _object._object; 13551 13552 Decl := 13553 Make_Object_Renaming_Declaration (Loc, 13554 Defining_Identifier => Prot_Ent, 13555 Subtype_Mark => 13556 New_Occurrence_Of (RTE (Prot_Typ), Loc), 13557 Name => 13558 Make_Selected_Component (Loc, 13559 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13560 Selector_Name => Make_Identifier (Loc, Name_uObject))); 13561 Add (Decl); 13562 end; 13563 end if; 13564 13565 -- Step 3: Add discriminant renamings (if any) 13566 13567 if Has_Discriminants (Conc_Typ) then 13568 declare 13569 D : Entity_Id; 13570 13571 begin 13572 D := First_Discriminant (Conc_Typ); 13573 while Present (D) loop 13574 13575 -- Adjust the source location 13576 13577 Set_Sloc (Discriminal (D), Loc); 13578 13579 -- Generate: 13580 -- discr_name : discr_typ renames _object.discr_name; 13581 -- or 13582 -- discr_name : discr_typ renames _task.discr_name; 13583 13584 Decl := 13585 Make_Object_Renaming_Declaration (Loc, 13586 Defining_Identifier => Discriminal (D), 13587 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc), 13588 Name => 13589 Make_Selected_Component (Loc, 13590 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13591 Selector_Name => Make_Identifier (Loc, Chars (D)))); 13592 Add (Decl); 13593 13594 -- Set debug info needed on this renaming declaration even 13595 -- though it does not come from source, so that the debugger 13596 -- will get the right information for these generated names. 13597 13598 Set_Debug_Info_Needed (Discriminal (D)); 13599 13600 Next_Discriminant (D); 13601 end loop; 13602 end; 13603 end if; 13604 13605 -- Step 4: Add private component renamings (if any) 13606 13607 if Is_Protected then 13608 Def := Protected_Definition (Parent (Conc_Typ)); 13609 13610 if Present (Private_Declarations (Def)) then 13611 declare 13612 Comp : Node_Id; 13613 Comp_Id : Entity_Id; 13614 Decl_Id : Entity_Id; 13615 13616 begin 13617 Comp := First (Private_Declarations (Def)); 13618 while Present (Comp) loop 13619 if Nkind (Comp) = N_Component_Declaration then 13620 Comp_Id := Defining_Identifier (Comp); 13621 Decl_Id := 13622 Make_Defining_Identifier (Loc, Chars (Comp_Id)); 13623 13624 -- Minimal decoration 13625 13626 if Ekind (Spec_Id) = E_Function then 13627 Set_Ekind (Decl_Id, E_Constant); 13628 else 13629 Set_Ekind (Decl_Id, E_Variable); 13630 end if; 13631 13632 Set_Prival (Comp_Id, Decl_Id); 13633 Set_Prival_Link (Decl_Id, Comp_Id); 13634 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); 13635 13636 -- Generate: 13637 -- comp_name : comp_typ renames _object.comp_name; 13638 13639 Decl := 13640 Make_Object_Renaming_Declaration (Loc, 13641 Defining_Identifier => Decl_Id, 13642 Subtype_Mark => 13643 New_Occurrence_Of (Etype (Comp_Id), Loc), 13644 Name => 13645 Make_Selected_Component (Loc, 13646 Prefix => 13647 New_Occurrence_Of (Obj_Ent, Loc), 13648 Selector_Name => 13649 Make_Identifier (Loc, Chars (Comp_Id)))); 13650 Add (Decl); 13651 end if; 13652 13653 Next (Comp); 13654 end loop; 13655 end; 13656 end if; 13657 end if; 13658 13659 -- Step 5: Add the declaration of the entry index and the associated 13660 -- type for barrier functions and entry families. 13661 13662 if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then 13663 declare 13664 E : constant Entity_Id := Index_Object (Spec_Id); 13665 Index : constant Entity_Id := 13666 Defining_Identifier 13667 (Entry_Index_Specification 13668 (Entry_Body_Formal_Part (Body_Nod))); 13669 Index_Con : constant Entity_Id := 13670 Make_Defining_Identifier (Loc, Chars (Index)); 13671 High : Node_Id; 13672 Index_Typ : Entity_Id; 13673 Low : Node_Id; 13674 13675 begin 13676 -- Minimal decoration 13677 13678 Set_Ekind (Index_Con, E_Constant); 13679 Set_Entry_Index_Constant (Index, Index_Con); 13680 Set_Discriminal_Link (Index_Con, Index); 13681 13682 -- Retrieve the bounds of the entry family 13683 13684 High := Type_High_Bound (Etype (Index)); 13685 Low := Type_Low_Bound (Etype (Index)); 13686 13687 -- In the simple case the entry family is given by a subtype mark 13688 -- and the index constant has the same type. 13689 13690 if Is_Entity_Name (Original_Node ( 13691 Discrete_Subtype_Definition (Parent (Index)))) 13692 then 13693 Index_Typ := Etype (Index); 13694 13695 -- Otherwise a new subtype declaration is required 13696 13697 else 13698 High := Replace_Bound (High); 13699 Low := Replace_Bound (Low); 13700 13701 Index_Typ := Make_Temporary (Loc, 'J'); 13702 13703 -- Generate: 13704 -- subtype Jnn is <Etype of Index> range Low .. High; 13705 13706 Decl := 13707 Make_Subtype_Declaration (Loc, 13708 Defining_Identifier => Index_Typ, 13709 Subtype_Indication => 13710 Make_Subtype_Indication (Loc, 13711 Subtype_Mark => 13712 New_Occurrence_Of (Base_Type (Etype (Index)), Loc), 13713 Constraint => 13714 Make_Range_Constraint (Loc, 13715 Range_Expression => 13716 Make_Range (Loc, Low, High)))); 13717 Add (Decl); 13718 end if; 13719 13720 Set_Etype (Index_Con, Index_Typ); 13721 13722 -- Create the object which designates the index: 13723 -- J : constant Jnn := 13724 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First)); 13725 -- 13726 -- where Jnn is the subtype created above or the original type of 13727 -- the index, _E is a formal of the protected body subprogram and 13728 -- <index expr> is the index of the first family member. 13729 13730 Decl := 13731 Make_Object_Declaration (Loc, 13732 Defining_Identifier => Index_Con, 13733 Constant_Present => True, 13734 Object_Definition => 13735 New_Occurrence_Of (Index_Typ, Loc), 13736 13737 Expression => 13738 Make_Attribute_Reference (Loc, 13739 Prefix => 13740 New_Occurrence_Of (Index_Typ, Loc), 13741 Attribute_Name => Name_Val, 13742 13743 Expressions => New_List ( 13744 13745 Make_Op_Add (Loc, 13746 Left_Opnd => 13747 Make_Op_Subtract (Loc, 13748 Left_Opnd => New_Occurrence_Of (E, Loc), 13749 Right_Opnd => 13750 Entry_Index_Expression (Loc, 13751 Defining_Identifier (Body_Nod), 13752 Empty, Conc_Typ)), 13753 13754 Right_Opnd => 13755 Make_Attribute_Reference (Loc, 13756 Prefix => 13757 New_Occurrence_Of (Index_Typ, Loc), 13758 Attribute_Name => Name_Pos, 13759 Expressions => New_List ( 13760 Make_Attribute_Reference (Loc, 13761 Prefix => 13762 New_Occurrence_Of (Index_Typ, Loc), 13763 Attribute_Name => Name_First))))))); 13764 Add (Decl); 13765 end; 13766 end if; 13767 end Install_Private_Data_Declarations; 13768 13769 --------------------------------- 13770 -- Is_Potentially_Large_Family -- 13771 --------------------------------- 13772 13773 function Is_Potentially_Large_Family 13774 (Base_Index : Entity_Id; 13775 Conctyp : Entity_Id; 13776 Lo : Node_Id; 13777 Hi : Node_Id) return Boolean 13778 is 13779 begin 13780 return Scope (Base_Index) = Standard_Standard 13781 and then Base_Index = Base_Type (Standard_Integer) 13782 and then Has_Discriminants (Conctyp) 13783 and then 13784 Present (Discriminant_Default_Value (First_Discriminant (Conctyp))) 13785 and then 13786 (Denotes_Discriminant (Lo, True) 13787 or else 13788 Denotes_Discriminant (Hi, True)); 13789 end Is_Potentially_Large_Family; 13790 13791 ------------------------------------- 13792 -- Is_Private_Primitive_Subprogram -- 13793 ------------------------------------- 13794 13795 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is 13796 begin 13797 return 13798 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure) 13799 and then Is_Private_Primitive (Id); 13800 end Is_Private_Primitive_Subprogram; 13801 13802 ------------------ 13803 -- Index_Object -- 13804 ------------------ 13805 13806 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is 13807 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id); 13808 Formal : Entity_Id; 13809 13810 begin 13811 Formal := First_Formal (Bod_Subp); 13812 while Present (Formal) loop 13813 13814 -- Look for formal parameter _E 13815 13816 if Chars (Formal) = Name_uE then 13817 return Formal; 13818 end if; 13819 13820 Next_Formal (Formal); 13821 end loop; 13822 13823 -- A protected body subprogram should always have the parameter in 13824 -- question. 13825 13826 raise Program_Error; 13827 end Index_Object; 13828 13829 -------------------------------- 13830 -- Make_Initialize_Protection -- 13831 -------------------------------- 13832 13833 function Make_Initialize_Protection 13834 (Protect_Rec : Entity_Id) return List_Id 13835 is 13836 Loc : constant Source_Ptr := Sloc (Protect_Rec); 13837 P_Arr : Entity_Id; 13838 Pdec : Node_Id; 13839 Ptyp : constant Node_Id := 13840 Corresponding_Concurrent_Type (Protect_Rec); 13841 Args : List_Id; 13842 L : constant List_Id := New_List; 13843 Has_Entry : constant Boolean := Has_Entries (Ptyp); 13844 Prio_Type : Entity_Id; 13845 Prio_Var : Entity_Id := Empty; 13846 Restricted : constant Boolean := Restricted_Profile; 13847 13848 begin 13849 -- We may need two calls to properly initialize the object, one to 13850 -- Initialize_Protection, and possibly one to Install_Handlers if we 13851 -- have a pragma Attach_Handler. 13852 13853 -- Get protected declaration. In the case of a task type declaration, 13854 -- this is simply the parent of the protected type entity. In the single 13855 -- protected object declaration, this parent will be the implicit type, 13856 -- and we can find the corresponding single protected object declaration 13857 -- by searching forward in the declaration list in the tree. 13858 13859 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes 13860 -- of this type should have been removed during semantic analysis. 13861 13862 Pdec := Parent (Ptyp); 13863 while not Nkind_In (Pdec, N_Protected_Type_Declaration, 13864 N_Single_Protected_Declaration) 13865 loop 13866 Next (Pdec); 13867 end loop; 13868 13869 -- Build the parameter list for the call. Note that _Init is the name 13870 -- of the formal for the object to be initialized, which is the task 13871 -- value record itself. 13872 13873 Args := New_List; 13874 13875 -- For lock-free implementation, skip initializations of the Protection 13876 -- object. 13877 13878 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 13879 13880 -- Object parameter. This is a pointer to the object of type 13881 -- Protection used by the GNARL to control the protected object. 13882 13883 Append_To (Args, 13884 Make_Attribute_Reference (Loc, 13885 Prefix => 13886 Make_Selected_Component (Loc, 13887 Prefix => Make_Identifier (Loc, Name_uInit), 13888 Selector_Name => Make_Identifier (Loc, Name_uObject)), 13889 Attribute_Name => Name_Unchecked_Access)); 13890 13891 -- Priority parameter. Set to Unspecified_Priority unless there is a 13892 -- Priority rep item, in which case we take the value from the pragma 13893 -- or attribute definition clause, or there is an Interrupt_Priority 13894 -- rep item and no Priority rep item, and we set the ceiling to 13895 -- Interrupt_Priority'Last, an implementation-defined value, see 13896 -- (RM D.3(10)). 13897 13898 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then 13899 declare 13900 Prio_Clause : constant Node_Id := 13901 Get_Rep_Item 13902 (Ptyp, Name_Priority, Check_Parents => False); 13903 13904 Prio : Node_Id; 13905 13906 begin 13907 -- Pragma Priority 13908 13909 if Nkind (Prio_Clause) = N_Pragma then 13910 Prio := 13911 Expression 13912 (First (Pragma_Argument_Associations (Prio_Clause))); 13913 13914 -- Get_Rep_Item returns either priority pragma 13915 13916 if Pragma_Name (Prio_Clause) = Name_Priority then 13917 Prio_Type := RTE (RE_Any_Priority); 13918 else 13919 Prio_Type := RTE (RE_Interrupt_Priority); 13920 end if; 13921 13922 -- Attribute definition clause Priority 13923 13924 else 13925 if Chars (Prio_Clause) = Name_Priority then 13926 Prio_Type := RTE (RE_Any_Priority); 13927 else 13928 Prio_Type := RTE (RE_Interrupt_Priority); 13929 end if; 13930 13931 Prio := Expression (Prio_Clause); 13932 end if; 13933 13934 -- Always create a locale variable to capture the priority. 13935 -- The priority is also passed to Install_Restriced_Handlers. 13936 -- Note that it is really necessary to create this variable 13937 -- explicitly. It might be thought that removing side effects 13938 -- would the appropriate approach, but that could generate 13939 -- declarations improperly placed in the enclosing scope. 13940 13941 Prio_Var := Make_Temporary (Loc, 'R', Prio); 13942 Append_To (L, 13943 Make_Object_Declaration (Loc, 13944 Defining_Identifier => Prio_Var, 13945 Object_Definition => New_Occurrence_Of (Prio_Type, Loc), 13946 Expression => Relocate_Node (Prio))); 13947 13948 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 13949 end; 13950 13951 -- When no priority is specified but an xx_Handler pragma is, we 13952 -- default to System.Interrupts.Default_Interrupt_Priority, see 13953 -- D.3(10). 13954 13955 elsif Has_Attach_Handler (Ptyp) 13956 or else Has_Interrupt_Handler (Ptyp) 13957 then 13958 Append_To (Args, 13959 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc)); 13960 13961 -- Normal case, no priority or xx_Handler specified, default priority 13962 13963 else 13964 Append_To (Args, 13965 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 13966 end if; 13967 13968 -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes 13969 13970 if Restricted_Profile and Task_Dispatching_Policy = 'E' then 13971 Deadline_Floor : declare 13972 Item : constant Node_Id := 13973 Get_Rep_Item 13974 (Ptyp, Name_Deadline_Floor, Check_Parents => False); 13975 13976 Deadline : Node_Id; 13977 13978 begin 13979 if Present (Item) then 13980 13981 -- Pragma Deadline_Floor 13982 13983 if Nkind (Item) = N_Pragma then 13984 Deadline := 13985 Expression 13986 (First (Pragma_Argument_Associations (Item))); 13987 13988 -- Attribute definition clause Deadline_Floor 13989 13990 else 13991 pragma Assert 13992 (Nkind (Item) = N_Attribute_Definition_Clause); 13993 13994 Deadline := Expression (Item); 13995 end if; 13996 13997 Append_To (Args, Deadline); 13998 13999 -- Unusual case: default deadline 14000 14001 else 14002 Append_To (Args, 14003 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 14004 end if; 14005 end Deadline_Floor; 14006 end if; 14007 14008 -- Test for Compiler_Info parameter. This parameter allows entry body 14009 -- procedures and barrier functions to be called from the runtime. It 14010 -- is a pointer to the record generated by the compiler to represent 14011 -- the protected object. 14012 14013 -- A protected type without entries that covers an interface and 14014 -- overrides the abstract routines with protected procedures is 14015 -- considered equivalent to a protected type with entries in the 14016 -- context of dispatching select statements. 14017 14018 -- Protected types with interrupt handlers (when not using a 14019 -- restricted profile) are also considered equivalent to protected 14020 -- types with entries. 14021 14022 -- The types which are used (Static_Interrupt_Protection and 14023 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries. 14024 14025 declare 14026 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); 14027 14028 Called_Subp : RE_Id; 14029 14030 begin 14031 case Pkg_Id is 14032 when System_Tasking_Protected_Objects_Entries => 14033 Called_Subp := RE_Initialize_Protection_Entries; 14034 14035 -- Argument Compiler_Info 14036 14037 Append_To (Args, 14038 Make_Attribute_Reference (Loc, 14039 Prefix => Make_Identifier (Loc, Name_uInit), 14040 Attribute_Name => Name_Address)); 14041 14042 when System_Tasking_Protected_Objects_Single_Entry => 14043 Called_Subp := RE_Initialize_Protection_Entry; 14044 14045 -- Argument Compiler_Info 14046 14047 Append_To (Args, 14048 Make_Attribute_Reference (Loc, 14049 Prefix => Make_Identifier (Loc, Name_uInit), 14050 Attribute_Name => Name_Address)); 14051 14052 when System_Tasking_Protected_Objects => 14053 Called_Subp := RE_Initialize_Protection; 14054 14055 when others => 14056 raise Program_Error; 14057 end case; 14058 14059 -- Entry_Queue_Maxes parameter. This is an access to an array of 14060 -- naturals representing the entry queue maximums for each entry 14061 -- in the protected type. Zero represents no max. The access is 14062 -- null if there is no limit for all entries (usual case). 14063 14064 if Has_Entry 14065 and then Pkg_Id = System_Tasking_Protected_Objects_Entries 14066 then 14067 if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then 14068 Append_To (Args, 14069 Make_Attribute_Reference (Loc, 14070 Prefix => 14071 New_Occurrence_Of 14072 (Entry_Max_Queue_Lengths_Array (Ptyp), Loc), 14073 Attribute_Name => Name_Unrestricted_Access)); 14074 else 14075 Append_To (Args, Make_Null (Loc)); 14076 end if; 14077 14078 -- Edge cases exist where entry initialization functions are 14079 -- called, but no entries exist, so null is appended. 14080 14081 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 14082 Append_To (Args, Make_Null (Loc)); 14083 end if; 14084 14085 -- Entry_Bodies parameter. This is a pointer to an array of 14086 -- pointers to the entry body procedures and barrier functions of 14087 -- the object. If the protected type has no entries this object 14088 -- will not exist, in this case, pass a null (it can happen when 14089 -- there are protected interrupt handlers or interfaces). 14090 14091 if Has_Entry then 14092 P_Arr := Entry_Bodies_Array (Ptyp); 14093 14094 -- Argument Entry_Body (for single entry) or Entry_Bodies (for 14095 -- multiple entries). 14096 14097 Append_To (Args, 14098 Make_Attribute_Reference (Loc, 14099 Prefix => New_Occurrence_Of (P_Arr, Loc), 14100 Attribute_Name => Name_Unrestricted_Access)); 14101 14102 if Pkg_Id = System_Tasking_Protected_Objects_Entries then 14103 14104 -- Find index mapping function (clumsy but ok for now) 14105 14106 while Ekind (P_Arr) /= E_Function loop 14107 Next_Entity (P_Arr); 14108 end loop; 14109 14110 Append_To (Args, 14111 Make_Attribute_Reference (Loc, 14112 Prefix => New_Occurrence_Of (P_Arr, Loc), 14113 Attribute_Name => Name_Unrestricted_Access)); 14114 end if; 14115 14116 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then 14117 14118 -- This is the case where we have a protected object with 14119 -- interfaces and no entries, and the single entry restriction 14120 -- is in effect. We pass a null pointer for the entry 14121 -- parameter because there is no actual entry. 14122 14123 Append_To (Args, Make_Null (Loc)); 14124 14125 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 14126 14127 -- This is the case where we have a protected object with no 14128 -- entries and: 14129 -- - either interrupt handlers with non restricted profile, 14130 -- - or interfaces 14131 -- Note that the types which are used for interrupt handlers 14132 -- (Static/Dynamic_Interrupt_Protection) are derived from 14133 -- Protection_Entries. We pass two null pointers because there 14134 -- is no actual entry, and the initialization procedure needs 14135 -- both Entry_Bodies and Find_Body_Index. 14136 14137 Append_To (Args, Make_Null (Loc)); 14138 Append_To (Args, Make_Null (Loc)); 14139 end if; 14140 14141 Append_To (L, 14142 Make_Procedure_Call_Statement (Loc, 14143 Name => 14144 New_Occurrence_Of (RTE (Called_Subp), Loc), 14145 Parameter_Associations => Args)); 14146 end; 14147 end if; 14148 14149 if Has_Attach_Handler (Ptyp) then 14150 14151 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to 14152 -- make the following call: 14153 14154 -- Install_Handlers (_object, 14155 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 14156 14157 -- or, in the case of Ravenscar: 14158 14159 -- Install_Restricted_Handlers 14160 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access))); 14161 14162 declare 14163 Args : constant List_Id := New_List; 14164 Table : constant List_Id := New_List; 14165 Ritem : Node_Id := First_Rep_Item (Ptyp); 14166 14167 begin 14168 -- Build the Priority parameter (only for ravenscar) 14169 14170 if Restricted then 14171 14172 -- Priority comes from a pragma 14173 14174 if Present (Prio_Var) then 14175 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 14176 14177 -- Priority is the default one 14178 14179 else 14180 Append_To (Args, 14181 New_Occurrence_Of 14182 (RTE (RE_Default_Interrupt_Priority), Loc)); 14183 end if; 14184 end if; 14185 14186 -- Build the Attach_Handler table argument 14187 14188 while Present (Ritem) loop 14189 if Nkind (Ritem) = N_Pragma 14190 and then Pragma_Name (Ritem) = Name_Attach_Handler 14191 then 14192 declare 14193 Handler : constant Node_Id := 14194 First (Pragma_Argument_Associations (Ritem)); 14195 14196 Interrupt : constant Node_Id := Next (Handler); 14197 Expr : constant Node_Id := Expression (Interrupt); 14198 14199 begin 14200 Append_To (Table, 14201 Make_Aggregate (Loc, Expressions => New_List ( 14202 Unchecked_Convert_To 14203 (RTE (RE_System_Interrupt_Id), Expr), 14204 Make_Attribute_Reference (Loc, 14205 Prefix => 14206 Make_Selected_Component (Loc, 14207 Prefix => 14208 Make_Identifier (Loc, Name_uInit), 14209 Selector_Name => 14210 Duplicate_Subexpr_No_Checks 14211 (Expression (Handler))), 14212 Attribute_Name => Name_Access)))); 14213 end; 14214 end if; 14215 14216 Next_Rep_Item (Ritem); 14217 end loop; 14218 14219 -- Append the table argument we just built 14220 14221 Append_To (Args, Make_Aggregate (Loc, Table)); 14222 14223 -- Append the Install_Handlers (or Install_Restricted_Handlers) 14224 -- call to the statements. 14225 14226 if Restricted then 14227 -- Call a simplified version of Install_Handlers to be used 14228 -- when the Ravenscar restrictions are in effect 14229 -- (Install_Restricted_Handlers). 14230 14231 Append_To (L, 14232 Make_Procedure_Call_Statement (Loc, 14233 Name => 14234 New_Occurrence_Of 14235 (RTE (RE_Install_Restricted_Handlers), Loc), 14236 Parameter_Associations => Args)); 14237 14238 else 14239 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 14240 14241 -- First, prepends the _object argument 14242 14243 Prepend_To (Args, 14244 Make_Attribute_Reference (Loc, 14245 Prefix => 14246 Make_Selected_Component (Loc, 14247 Prefix => Make_Identifier (Loc, Name_uInit), 14248 Selector_Name => 14249 Make_Identifier (Loc, Name_uObject)), 14250 Attribute_Name => Name_Unchecked_Access)); 14251 end if; 14252 14253 -- Then, insert call to Install_Handlers 14254 14255 Append_To (L, 14256 Make_Procedure_Call_Statement (Loc, 14257 Name => 14258 New_Occurrence_Of (RTE (RE_Install_Handlers), Loc), 14259 Parameter_Associations => Args)); 14260 end if; 14261 end; 14262 end if; 14263 14264 return L; 14265 end Make_Initialize_Protection; 14266 14267 --------------------------- 14268 -- Make_Task_Create_Call -- 14269 --------------------------- 14270 14271 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is 14272 Loc : constant Source_Ptr := Sloc (Task_Rec); 14273 Args : List_Id; 14274 Ecount : Node_Id; 14275 Name : Node_Id; 14276 Tdec : Node_Id; 14277 Tdef : Node_Id; 14278 Tnam : Name_Id; 14279 Ttyp : Node_Id; 14280 14281 begin 14282 Ttyp := Corresponding_Concurrent_Type (Task_Rec); 14283 Tnam := Chars (Ttyp); 14284 14285 -- Get task declaration. In the case of a task type declaration, this is 14286 -- simply the parent of the task type entity. In the single task 14287 -- declaration, this parent will be the implicit type, and we can find 14288 -- the corresponding single task declaration by searching forward in the 14289 -- declaration list in the tree. 14290 14291 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of 14292 -- this type should have been removed during semantic analysis. 14293 14294 Tdec := Parent (Ttyp); 14295 while not Nkind_In (Tdec, N_Task_Type_Declaration, 14296 N_Single_Task_Declaration) 14297 loop 14298 Next (Tdec); 14299 end loop; 14300 14301 -- Now we can find the task definition from this declaration 14302 14303 Tdef := Task_Definition (Tdec); 14304 14305 -- Build the parameter list for the call. Note that _Init is the name 14306 -- of the formal for the object to be initialized, which is the task 14307 -- value record itself. 14308 14309 Args := New_List; 14310 14311 -- Priority parameter. Set to Unspecified_Priority unless there is a 14312 -- Priority rep item, in which case we take the value from the rep item. 14313 -- Not used on Ravenscar_EDF profile. 14314 14315 if not (Restricted_Profile and then Task_Dispatching_Policy = 'E') then 14316 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then 14317 Append_To (Args, 14318 Make_Selected_Component (Loc, 14319 Prefix => Make_Identifier (Loc, Name_uInit), 14320 Selector_Name => Make_Identifier (Loc, Name_uPriority))); 14321 else 14322 Append_To (Args, 14323 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 14324 end if; 14325 end if; 14326 14327 -- Optional Stack parameter 14328 14329 if Restricted_Profile then 14330 14331 -- If the stack has been preallocated by the expander then 14332 -- pass its address. Otherwise, pass a null address. 14333 14334 if Preallocated_Stacks_On_Target then 14335 Append_To (Args, 14336 Make_Attribute_Reference (Loc, 14337 Prefix => 14338 Make_Selected_Component (Loc, 14339 Prefix => Make_Identifier (Loc, Name_uInit), 14340 Selector_Name => Make_Identifier (Loc, Name_uStack)), 14341 Attribute_Name => Name_Address)); 14342 14343 else 14344 Append_To (Args, 14345 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 14346 end if; 14347 end if; 14348 14349 -- Size parameter. If no Storage_Size pragma is present, then 14350 -- the size is taken from the taskZ variable for the type, which 14351 -- is either Unspecified_Size, or has been reset by the use of 14352 -- a Storage_Size attribute definition clause. If a pragma is 14353 -- present, then the size is taken from the _Size field of the 14354 -- task value record, which was set from the pragma value. 14355 14356 if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then 14357 Append_To (Args, 14358 Make_Selected_Component (Loc, 14359 Prefix => Make_Identifier (Loc, Name_uInit), 14360 Selector_Name => Make_Identifier (Loc, Name_uSize))); 14361 14362 else 14363 Append_To (Args, 14364 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc)); 14365 end if; 14366 14367 -- Secondary_Stack parameter used for restricted profiles 14368 14369 if Restricted_Profile then 14370 14371 -- If the secondary stack has been allocated by the expander then 14372 -- pass its access pointer. Otherwise, pass null. 14373 14374 if Create_Secondary_Stack_For_Task (Ttyp) then 14375 Append_To (Args, 14376 Make_Attribute_Reference (Loc, 14377 Prefix => 14378 Make_Selected_Component (Loc, 14379 Prefix => Make_Identifier (Loc, Name_uInit), 14380 Selector_Name => 14381 Make_Identifier (Loc, Name_uSecondary_Stack)), 14382 Attribute_Name => Name_Unrestricted_Access)); 14383 14384 else 14385 Append_To (Args, Make_Null (Loc)); 14386 end if; 14387 end if; 14388 14389 -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there 14390 -- is a Secondary_Stack_Size pragma, in which case take the value from 14391 -- the pragma. If the restriction No_Secondary_Stack is active then a 14392 -- size of 0 is passed regardless to prevent the allocation of the 14393 -- unused stack. 14394 14395 if Restriction_Active (No_Secondary_Stack) then 14396 Append_To (Args, Make_Integer_Literal (Loc, 0)); 14397 14398 elsif Has_Rep_Pragma 14399 (Ttyp, Name_Secondary_Stack_Size, Check_Parents => False) 14400 then 14401 Append_To (Args, 14402 Make_Selected_Component (Loc, 14403 Prefix => Make_Identifier (Loc, Name_uInit), 14404 Selector_Name => 14405 Make_Identifier (Loc, Name_uSecondary_Stack_Size))); 14406 14407 else 14408 Append_To (Args, 14409 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 14410 end if; 14411 14412 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a 14413 -- Task_Info pragma, in which case we take the value from the pragma. 14414 14415 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then 14416 Append_To (Args, 14417 Make_Selected_Component (Loc, 14418 Prefix => Make_Identifier (Loc, Name_uInit), 14419 Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); 14420 14421 else 14422 Append_To (Args, 14423 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc)); 14424 end if; 14425 14426 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item, 14427 -- in which case we take the value from the rep item. The parameter is 14428 -- passed as an Integer because in the case of unspecified CPU the 14429 -- value is not in the range of CPU_Range. 14430 14431 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then 14432 Append_To (Args, 14433 Convert_To (Standard_Integer, 14434 Make_Selected_Component (Loc, 14435 Prefix => Make_Identifier (Loc, Name_uInit), 14436 Selector_Name => Make_Identifier (Loc, Name_uCPU)))); 14437 else 14438 Append_To (Args, 14439 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc)); 14440 end if; 14441 14442 if not Restricted_Profile or else Task_Dispatching_Policy = 'E' then 14443 14444 -- Deadline parameter. If no Relative_Deadline pragma is present, 14445 -- then the deadline is Time_Span_Zero. If a pragma is present, then 14446 -- the deadline is taken from the _Relative_Deadline field of the 14447 -- task value record, which was set from the pragma value. Note that 14448 -- this parameter must not be generated for the restricted profiles 14449 -- since Ravenscar does not allow deadlines. 14450 14451 -- Case where pragma Relative_Deadline applies: use given value 14452 14453 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then 14454 Append_To (Args, 14455 Make_Selected_Component (Loc, 14456 Prefix => Make_Identifier (Loc, Name_uInit), 14457 Selector_Name => 14458 Make_Identifier (Loc, Name_uRelative_Deadline))); 14459 14460 -- No pragma Relative_Deadline apply to the task 14461 14462 else 14463 Append_To (Args, 14464 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 14465 end if; 14466 end if; 14467 14468 if not Restricted_Profile then 14469 14470 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is 14471 -- present, then the dispatching domain is null. If a rep item is 14472 -- present, then the dispatching domain is taken from the 14473 -- _Dispatching_Domain field of the task value record, which was set 14474 -- from the rep item value. 14475 14476 -- Case where Dispatching_Domain rep item applies: use given value 14477 14478 if Has_Rep_Item 14479 (Ttyp, Name_Dispatching_Domain, Check_Parents => False) 14480 then 14481 Append_To (Args, 14482 Make_Selected_Component (Loc, 14483 Prefix => 14484 Make_Identifier (Loc, Name_uInit), 14485 Selector_Name => 14486 Make_Identifier (Loc, Name_uDispatching_Domain))); 14487 14488 -- No pragma or aspect Dispatching_Domain applies to the task 14489 14490 else 14491 Append_To (Args, Make_Null (Loc)); 14492 end if; 14493 14494 -- Number of entries. This is an expression of the form: 14495 14496 -- n + _Init.a'Length + _Init.a'B'Length + ... 14497 14498 -- where a,b... are the entry family names for the task definition 14499 14500 Ecount := 14501 Build_Entry_Count_Expression 14502 (Ttyp, 14503 Component_Items 14504 (Component_List 14505 (Type_Definition 14506 (Parent (Corresponding_Record_Type (Ttyp))))), 14507 Loc); 14508 Append_To (Args, Ecount); 14509 14510 -- Master parameter. This is a reference to the _Master parameter of 14511 -- the initialization procedure, except in the case of the pragma 14512 -- Restrictions (No_Task_Hierarchy) where the value is fixed to 14513 -- System.Tasking.Library_Task_Level. 14514 14515 if Restriction_Active (No_Task_Hierarchy) = False then 14516 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 14517 else 14518 Append_To (Args, 14519 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 14520 end if; 14521 end if; 14522 14523 -- State parameter. This is a pointer to the task body procedure. The 14524 -- required value is obtained by taking 'Unrestricted_Access of the task 14525 -- body procedure and converting it (with an unchecked conversion) to 14526 -- the type required by the task kernel. For further details, see the 14527 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather 14528 -- than 'Address in order to avoid creating trampolines. 14529 14530 declare 14531 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp); 14532 Subp_Ptr_Typ : constant Node_Id := 14533 Create_Itype (E_Access_Subprogram_Type, Tdec); 14534 Ref : constant Node_Id := Make_Itype_Reference (Loc); 14535 14536 begin 14537 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc); 14538 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); 14539 14540 -- Be sure to freeze a reference to the access-to-subprogram type, 14541 -- otherwise gigi will complain that it's in the wrong scope, because 14542 -- it's actually inside the init procedure for the record type that 14543 -- corresponds to the task type. 14544 14545 Set_Itype (Ref, Subp_Ptr_Typ); 14546 Append_Freeze_Action (Task_Rec, Ref); 14547 14548 Append_To (Args, 14549 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), 14550 Make_Qualified_Expression (Loc, 14551 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), 14552 Expression => 14553 Make_Attribute_Reference (Loc, 14554 Prefix => New_Occurrence_Of (Body_Proc, Loc), 14555 Attribute_Name => Name_Unrestricted_Access)))); 14556 end; 14557 14558 -- Discriminants parameter. This is just the address of the task 14559 -- value record itself (which contains the discriminant values 14560 14561 Append_To (Args, 14562 Make_Attribute_Reference (Loc, 14563 Prefix => Make_Identifier (Loc, Name_uInit), 14564 Attribute_Name => Name_Address)); 14565 14566 -- Elaborated parameter. This is an access to the elaboration Boolean 14567 14568 Append_To (Args, 14569 Make_Attribute_Reference (Loc, 14570 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')), 14571 Attribute_Name => Name_Unchecked_Access)); 14572 14573 -- Add Chain parameter (not done for sequential elaboration policy, see 14574 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 14575 14576 if Partition_Elaboration_Policy /= 'S' then 14577 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 14578 end if; 14579 14580 -- Task name parameter. Take this from the _Task_Id parameter to the 14581 -- init call unless there is a Task_Name pragma, in which case we take 14582 -- the value from the pragma. 14583 14584 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then 14585 -- Copy expression in full, because it may be dynamic and have 14586 -- side effects. 14587 14588 Append_To (Args, 14589 New_Copy_Tree 14590 (Expression 14591 (First 14592 (Pragma_Argument_Associations 14593 (Get_Rep_Pragma 14594 (Ttyp, Name_Task_Name, Check_Parents => False)))))); 14595 14596 else 14597 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); 14598 end if; 14599 14600 -- Created_Task parameter. This is the _Task_Id field of the task 14601 -- record value 14602 14603 Append_To (Args, 14604 Make_Selected_Component (Loc, 14605 Prefix => Make_Identifier (Loc, Name_uInit), 14606 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); 14607 14608 declare 14609 Create_RE : RE_Id; 14610 14611 begin 14612 if Restricted_Profile then 14613 if Partition_Elaboration_Policy = 'S' then 14614 Create_RE := RE_Create_Restricted_Task_Sequential; 14615 else 14616 Create_RE := RE_Create_Restricted_Task; 14617 end if; 14618 else 14619 Create_RE := RE_Create_Task; 14620 end if; 14621 14622 Name := New_Occurrence_Of (RTE (Create_RE), Loc); 14623 end; 14624 14625 return 14626 Make_Procedure_Call_Statement (Loc, 14627 Name => Name, 14628 Parameter_Associations => Args); 14629 end Make_Task_Create_Call; 14630 14631 ------------------------------ 14632 -- Next_Protected_Operation -- 14633 ------------------------------ 14634 14635 function Next_Protected_Operation (N : Node_Id) return Node_Id is 14636 Next_Op : Node_Id; 14637 14638 begin 14639 -- Check whether there is a subsequent body for a protected operation 14640 -- in the current protected body. In Ada2012 that includes expression 14641 -- functions that are completions. 14642 14643 Next_Op := Next (N); 14644 while Present (Next_Op) 14645 and then not Nkind_In (Next_Op, 14646 N_Subprogram_Body, N_Entry_Body, N_Expression_Function) 14647 loop 14648 Next (Next_Op); 14649 end loop; 14650 14651 return Next_Op; 14652 end Next_Protected_Operation; 14653 14654 --------------------- 14655 -- Null_Statements -- 14656 --------------------- 14657 14658 function Null_Statements (Stats : List_Id) return Boolean is 14659 Stmt : Node_Id; 14660 14661 begin 14662 Stmt := First (Stats); 14663 while Nkind (Stmt) /= N_Empty 14664 and then (Nkind_In (Stmt, N_Null_Statement, N_Label) 14665 or else 14666 (Nkind (Stmt) = N_Pragma 14667 and then 14668 Nam_In (Pragma_Name_Unmapped (Stmt), 14669 Name_Unreferenced, 14670 Name_Unmodified, 14671 Name_Warnings))) 14672 loop 14673 Next (Stmt); 14674 end loop; 14675 14676 return Nkind (Stmt) = N_Empty; 14677 end Null_Statements; 14678 14679 -------------------------- 14680 -- Parameter_Block_Pack -- 14681 -------------------------- 14682 14683 function Parameter_Block_Pack 14684 (Loc : Source_Ptr; 14685 Blk_Typ : Entity_Id; 14686 Actuals : List_Id; 14687 Formals : List_Id; 14688 Decls : List_Id; 14689 Stmts : List_Id) return Node_Id 14690 is 14691 Actual : Entity_Id; 14692 Expr : Node_Id := Empty; 14693 Formal : Entity_Id; 14694 Has_Param : Boolean := False; 14695 P : Entity_Id; 14696 Params : List_Id; 14697 Temp_Asn : Node_Id; 14698 Temp_Nam : Node_Id; 14699 14700 begin 14701 Actual := First (Actuals); 14702 Formal := Defining_Identifier (First (Formals)); 14703 Params := New_List; 14704 while Present (Actual) loop 14705 if Is_By_Copy_Type (Etype (Actual)) then 14706 -- Generate: 14707 -- Jnn : aliased <formal-type> 14708 14709 Temp_Nam := Make_Temporary (Loc, 'J'); 14710 14711 Append_To (Decls, 14712 Make_Object_Declaration (Loc, 14713 Aliased_Present => True, 14714 Defining_Identifier => Temp_Nam, 14715 Object_Definition => 14716 New_Occurrence_Of (Etype (Formal), Loc))); 14717 14718 -- The object is initialized with an explicit assignment 14719 -- later. Indicate that it does not need an initialization 14720 -- to prevent spurious warnings if the type excludes null. 14721 14722 Set_No_Initialization (Last (Decls)); 14723 14724 if Ekind (Formal) /= E_Out_Parameter then 14725 14726 -- Generate: 14727 -- Jnn := <actual> 14728 14729 Temp_Asn := 14730 New_Occurrence_Of (Temp_Nam, Loc); 14731 14732 Set_Assignment_OK (Temp_Asn); 14733 14734 Append_To (Stmts, 14735 Make_Assignment_Statement (Loc, 14736 Name => Temp_Asn, 14737 Expression => New_Copy_Tree (Actual))); 14738 end if; 14739 14740 -- If the actual is not controlling, generate: 14741 14742 -- Jnn'unchecked_access 14743 14744 -- and add it to aggegate for access to formals. Note that the 14745 -- actual may be by-copy but still be a controlling actual if it 14746 -- is an access to class-wide interface. 14747 14748 if not Is_Controlling_Actual (Actual) then 14749 Append_To (Params, 14750 Make_Attribute_Reference (Loc, 14751 Attribute_Name => Name_Unchecked_Access, 14752 Prefix => New_Occurrence_Of (Temp_Nam, Loc))); 14753 14754 Has_Param := True; 14755 end if; 14756 14757 -- The controlling parameter is omitted 14758 14759 else 14760 if not Is_Controlling_Actual (Actual) then 14761 Append_To (Params, 14762 Make_Reference (Loc, New_Copy_Tree (Actual))); 14763 14764 Has_Param := True; 14765 end if; 14766 end if; 14767 14768 Next_Actual (Actual); 14769 Next_Formal_With_Extras (Formal); 14770 end loop; 14771 14772 if Has_Param then 14773 Expr := Make_Aggregate (Loc, Params); 14774 end if; 14775 14776 -- Generate: 14777 -- P : Ann := ( 14778 -- J1'unchecked_access; 14779 -- <actual2>'reference; 14780 -- ...); 14781 14782 P := Make_Temporary (Loc, 'P'); 14783 14784 Append_To (Decls, 14785 Make_Object_Declaration (Loc, 14786 Defining_Identifier => P, 14787 Object_Definition => New_Occurrence_Of (Blk_Typ, Loc), 14788 Expression => Expr)); 14789 14790 return P; 14791 end Parameter_Block_Pack; 14792 14793 ---------------------------- 14794 -- Parameter_Block_Unpack -- 14795 ---------------------------- 14796 14797 function Parameter_Block_Unpack 14798 (Loc : Source_Ptr; 14799 P : Entity_Id; 14800 Actuals : List_Id; 14801 Formals : List_Id) return List_Id 14802 is 14803 Actual : Entity_Id; 14804 Asnmt : Node_Id; 14805 Formal : Entity_Id; 14806 Has_Asnmt : Boolean := False; 14807 Result : constant List_Id := New_List; 14808 14809 begin 14810 Actual := First (Actuals); 14811 Formal := Defining_Identifier (First (Formals)); 14812 while Present (Actual) loop 14813 if Is_By_Copy_Type (Etype (Actual)) 14814 and then Ekind (Formal) /= E_In_Parameter 14815 then 14816 -- Generate: 14817 -- <actual> := P.<formal>; 14818 14819 Asnmt := 14820 Make_Assignment_Statement (Loc, 14821 Name => 14822 New_Copy (Actual), 14823 Expression => 14824 Make_Explicit_Dereference (Loc, 14825 Make_Selected_Component (Loc, 14826 Prefix => 14827 New_Occurrence_Of (P, Loc), 14828 Selector_Name => 14829 Make_Identifier (Loc, Chars (Formal))))); 14830 14831 Set_Assignment_OK (Name (Asnmt)); 14832 Append_To (Result, Asnmt); 14833 14834 Has_Asnmt := True; 14835 end if; 14836 14837 Next_Actual (Actual); 14838 Next_Formal_With_Extras (Formal); 14839 end loop; 14840 14841 if Has_Asnmt then 14842 return Result; 14843 else 14844 return New_List (Make_Null_Statement (Loc)); 14845 end if; 14846 end Parameter_Block_Unpack; 14847 14848 --------------------- 14849 -- Reset_Scopes_To -- 14850 --------------------- 14851 14852 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is 14853 function Reset_Scope (N : Node_Id) return Traverse_Result; 14854 -- Temporaries may have been declared during expansion of the procedure 14855 -- created for an entry body or an accept alternative. Indicate that 14856 -- their scope is the new body, to ensure proper generation of uplevel 14857 -- references where needed during unnesting. 14858 14859 procedure Reset_Scopes is new Traverse_Proc (Reset_Scope); 14860 14861 ----------------- 14862 -- Reset_Scope -- 14863 ----------------- 14864 14865 function Reset_Scope (N : Node_Id) return Traverse_Result is 14866 Decl : Node_Id; 14867 14868 begin 14869 -- If this is a block statement with an Identifier, it forms a scope, 14870 -- so we want to reset its scope but not look inside. 14871 14872 if N /= Bod 14873 and then Nkind (N) = N_Block_Statement 14874 and then Present (Identifier (N)) 14875 then 14876 Set_Scope (Entity (Identifier (N)), E); 14877 return Skip; 14878 14879 -- Ditto for a package declaration or a full type declaration, etc. 14880 14881 elsif Nkind (N) = N_Package_Declaration 14882 or else Nkind (N) in N_Declaration 14883 or else Nkind (N) in N_Renaming_Declaration 14884 then 14885 Set_Scope (Defining_Entity (N), E); 14886 return Skip; 14887 14888 elsif N = Bod then 14889 14890 -- Scan declarations in new body. Declarations in the statement 14891 -- part will be handled during later traversal. 14892 14893 Decl := First (Declarations (N)); 14894 while Present (Decl) loop 14895 Reset_Scopes (Decl); 14896 Next (Decl); 14897 end loop; 14898 14899 elsif N /= Bod and then Nkind (N) in N_Proper_Body then 14900 return Skip; 14901 end if; 14902 14903 return OK; 14904 end Reset_Scope; 14905 14906 -- Start of processing for Reset_Scopes_To 14907 14908 begin 14909 Reset_Scopes (Bod); 14910 end Reset_Scopes_To; 14911 14912 ---------------------- 14913 -- Set_Discriminals -- 14914 ---------------------- 14915 14916 procedure Set_Discriminals (Dec : Node_Id) is 14917 D : Entity_Id; 14918 Pdef : Entity_Id; 14919 D_Minal : Entity_Id; 14920 14921 begin 14922 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); 14923 Pdef := Defining_Identifier (Dec); 14924 14925 if Has_Discriminants (Pdef) then 14926 D := First_Discriminant (Pdef); 14927 while Present (D) loop 14928 D_Minal := 14929 Make_Defining_Identifier (Sloc (D), 14930 Chars => New_External_Name (Chars (D), 'D')); 14931 14932 Set_Ekind (D_Minal, E_Constant); 14933 Set_Etype (D_Minal, Etype (D)); 14934 Set_Scope (D_Minal, Pdef); 14935 Set_Discriminal (D, D_Minal); 14936 Set_Discriminal_Link (D_Minal, D); 14937 14938 Next_Discriminant (D); 14939 end loop; 14940 end if; 14941 end Set_Discriminals; 14942 14943 ----------------------- 14944 -- Trivial_Accept_OK -- 14945 ----------------------- 14946 14947 function Trivial_Accept_OK return Boolean is 14948 begin 14949 case Opt.Task_Dispatching_Policy is 14950 14951 -- If we have the default task dispatching policy in effect, we can 14952 -- definitely do the optimization (one way of looking at this is to 14953 -- think of the formal definition of the default policy being allowed 14954 -- to run any task it likes after a rendezvous, so even if notionally 14955 -- a full rescheduling occurs, we can say that our dispatching policy 14956 -- (i.e. the default dispatching policy) reorders the queue to be the 14957 -- same as just before the call. 14958 14959 when ' ' => 14960 return True; 14961 14962 -- FIFO_Within_Priorities certainly does not permit this 14963 -- optimization since the Rendezvous is a scheduling action that may 14964 -- require some other task to be run. 14965 14966 when 'F' => 14967 return False; 14968 14969 -- For now, disallow the optimization for all other policies. This 14970 -- may be over-conservative, but it is certainly not incorrect. 14971 14972 when others => 14973 return False; 14974 end case; 14975 end Trivial_Accept_OK; 14976 14977end Exp_Ch9; 14978