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 System.Relative_Delays.Delay_For only if available. This 8262 -- is the implementation used on restricted platforms when Ada.Calendar 8263 -- is not available. 8264 8265 if RTE_Available (RO_RD_Delay_For) then 8266 Proc := RTE (RO_RD_Delay_For); 8267 8268 -- Otherwise, use Ada.Calendar.Delays.Delay_For and emit an error 8269 -- message if not available. 8270 8271 else 8272 Proc := RTE (RO_CA_Delay_For); 8273 end if; 8274 8275 Rewrite (N, 8276 Make_Procedure_Call_Statement (Loc, 8277 Name => New_Occurrence_Of (Proc, Loc), 8278 Parameter_Associations => New_List (Expression (N)))); 8279 Analyze (N); 8280 end Expand_N_Delay_Relative_Statement; 8281 8282 ------------------------------------ 8283 -- Expand_N_Delay_Until_Statement -- 8284 ------------------------------------ 8285 8286 -- Delay Until statement is implemented as a procedure call to 8287 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays. 8288 8289 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is 8290 Loc : constant Source_Ptr := Sloc (N); 8291 Typ : Entity_Id; 8292 8293 begin 8294 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then 8295 Typ := RTE (RO_CA_Delay_Until); 8296 else 8297 Typ := RTE (RO_RT_Delay_Until); 8298 end if; 8299 8300 Rewrite (N, 8301 Make_Procedure_Call_Statement (Loc, 8302 Name => New_Occurrence_Of (Typ, Loc), 8303 Parameter_Associations => New_List (Expression (N)))); 8304 8305 Analyze (N); 8306 end Expand_N_Delay_Until_Statement; 8307 8308 ------------------------- 8309 -- Expand_N_Entry_Body -- 8310 ------------------------- 8311 8312 procedure Expand_N_Entry_Body (N : Node_Id) is 8313 begin 8314 -- Associate discriminals with the next protected operation body to be 8315 -- expanded. 8316 8317 if Present (Next_Protected_Operation (N)) then 8318 Set_Discriminals (Parent (Current_Scope)); 8319 end if; 8320 end Expand_N_Entry_Body; 8321 8322 ----------------------------------- 8323 -- Expand_N_Entry_Call_Statement -- 8324 ----------------------------------- 8325 8326 -- An entry call is expanded into GNARLI calls to implement a simple entry 8327 -- call (see Build_Simple_Entry_Call). 8328 8329 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is 8330 Concval : Node_Id; 8331 Ename : Node_Id; 8332 Index : Node_Id; 8333 8334 begin 8335 if No_Run_Time_Mode then 8336 Error_Msg_CRT ("entry call", N); 8337 return; 8338 end if; 8339 8340 -- If this entry call is part of an asynchronous select, don't expand it 8341 -- here; it will be expanded with the select statement. Don't expand 8342 -- timed entry calls either, as they are translated into asynchronous 8343 -- entry calls. 8344 8345 -- ??? This whole approach is questionable; it may be better to go back 8346 -- to allowing the expansion to take place and then attempting to fix it 8347 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out 8348 -- whether the expanded call is on a task or protected entry. 8349 8350 if (Nkind (Parent (N)) /= N_Triggering_Alternative 8351 or else N /= Triggering_Statement (Parent (N))) 8352 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative 8353 or else N /= Entry_Call_Statement (Parent (N)) 8354 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call) 8355 then 8356 Extract_Entry (N, Concval, Ename, Index); 8357 Build_Simple_Entry_Call (N, Concval, Ename, Index); 8358 end if; 8359 end Expand_N_Entry_Call_Statement; 8360 8361 -------------------------------- 8362 -- Expand_N_Entry_Declaration -- 8363 -------------------------------- 8364 8365 -- If there are parameters, then first, each of the formals is marked by 8366 -- setting Is_Entry_Formal. Next a record type is built which is used to 8367 -- hold the parameter values. The name of this record type is entryP where 8368 -- entry is the name of the entry, with an additional corresponding access 8369 -- type called entryPA. The record type has matching components for each 8370 -- formal (the component names are the same as the formal names). For 8371 -- elementary types, the component type matches the formal type. For 8372 -- composite types, an access type is declared (with the name formalA) 8373 -- which designates the formal type, and the type of the component is this 8374 -- access type. Finally the Entry_Component of each formal is set to 8375 -- reference the corresponding record component. 8376 8377 procedure Expand_N_Entry_Declaration (N : Node_Id) is 8378 Loc : constant Source_Ptr := Sloc (N); 8379 Entry_Ent : constant Entity_Id := Defining_Identifier (N); 8380 Components : List_Id; 8381 Formal : Node_Id; 8382 Ftype : Entity_Id; 8383 Last_Decl : Node_Id; 8384 Component : Entity_Id; 8385 Ctype : Entity_Id; 8386 Decl : Node_Id; 8387 Rec_Ent : Entity_Id; 8388 Acc_Ent : Entity_Id; 8389 8390 begin 8391 Formal := First_Formal (Entry_Ent); 8392 Last_Decl := N; 8393 8394 -- Most processing is done only if parameters are present 8395 8396 if Present (Formal) then 8397 Components := New_List; 8398 8399 -- Loop through formals 8400 8401 while Present (Formal) loop 8402 Set_Is_Entry_Formal (Formal); 8403 Component := 8404 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); 8405 Set_Entry_Component (Formal, Component); 8406 Set_Entry_Formal (Component, Formal); 8407 Ftype := Etype (Formal); 8408 8409 -- Declare new access type and then append 8410 8411 Ctype := Make_Temporary (Loc, 'A'); 8412 Set_Is_Param_Block_Component_Type (Ctype); 8413 8414 Decl := 8415 Make_Full_Type_Declaration (Loc, 8416 Defining_Identifier => Ctype, 8417 Type_Definition => 8418 Make_Access_To_Object_Definition (Loc, 8419 All_Present => True, 8420 Constant_Present => Ekind (Formal) = E_In_Parameter, 8421 Subtype_Indication => New_Occurrence_Of (Ftype, Loc))); 8422 8423 Insert_After (Last_Decl, Decl); 8424 Last_Decl := Decl; 8425 8426 Append_To (Components, 8427 Make_Component_Declaration (Loc, 8428 Defining_Identifier => Component, 8429 Component_Definition => 8430 Make_Component_Definition (Loc, 8431 Aliased_Present => False, 8432 Subtype_Indication => New_Occurrence_Of (Ctype, Loc)))); 8433 8434 Next_Formal_With_Extras (Formal); 8435 end loop; 8436 8437 -- Create the Entry_Parameter_Record declaration 8438 8439 Rec_Ent := Make_Temporary (Loc, 'P'); 8440 8441 Decl := 8442 Make_Full_Type_Declaration (Loc, 8443 Defining_Identifier => Rec_Ent, 8444 Type_Definition => 8445 Make_Record_Definition (Loc, 8446 Component_List => 8447 Make_Component_List (Loc, 8448 Component_Items => Components))); 8449 8450 Insert_After (Last_Decl, Decl); 8451 Last_Decl := Decl; 8452 8453 -- Construct and link in the corresponding access type 8454 8455 Acc_Ent := Make_Temporary (Loc, 'A'); 8456 8457 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); 8458 8459 Decl := 8460 Make_Full_Type_Declaration (Loc, 8461 Defining_Identifier => Acc_Ent, 8462 Type_Definition => 8463 Make_Access_To_Object_Definition (Loc, 8464 All_Present => True, 8465 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc))); 8466 8467 Insert_After (Last_Decl, Decl); 8468 end if; 8469 end Expand_N_Entry_Declaration; 8470 8471 ----------------------------- 8472 -- Expand_N_Protected_Body -- 8473 ----------------------------- 8474 8475 -- Protected bodies are expanded to the completion of the subprograms 8476 -- created for the corresponding protected type. These are a protected and 8477 -- unprotected version of each protected subprogram in the object, a 8478 -- function to calculate each entry barrier, and a procedure to execute the 8479 -- sequence of statements of each protected entry body. For example, for 8480 -- protected type ptype: 8481 8482 -- function entB 8483 -- (O : System.Address; 8484 -- E : Protected_Entry_Index) 8485 -- return Boolean 8486 -- is 8487 -- <discriminant renamings> 8488 -- <private object renamings> 8489 -- begin 8490 -- return <barrier expression>; 8491 -- end entB; 8492 8493 -- procedure pprocN (_object : in out poV;...) is 8494 -- <discriminant renamings> 8495 -- <private object renamings> 8496 -- begin 8497 -- <sequence of statements> 8498 -- end pprocN; 8499 8500 -- procedure pprocP (_object : in out poV;...) is 8501 -- procedure _clean is 8502 -- Pn : Boolean; 8503 -- begin 8504 -- ptypeS (_object, Pn); 8505 -- Unlock (_object._object'Access); 8506 -- Abort_Undefer.all; 8507 -- end _clean; 8508 8509 -- begin 8510 -- Abort_Defer.all; 8511 -- Lock (_object._object'Access); 8512 -- pprocN (_object;...); 8513 -- at end 8514 -- _clean; 8515 -- end pproc; 8516 8517 -- function pfuncN (_object : poV;...) return Return_Type is 8518 -- <discriminant renamings> 8519 -- <private object renamings> 8520 -- begin 8521 -- <sequence of statements> 8522 -- end pfuncN; 8523 8524 -- function pfuncP (_object : poV) return Return_Type is 8525 -- procedure _clean is 8526 -- begin 8527 -- Unlock (_object._object'Access); 8528 -- Abort_Undefer.all; 8529 -- end _clean; 8530 8531 -- begin 8532 -- Abort_Defer.all; 8533 -- Lock (_object._object'Access); 8534 -- return pfuncN (_object); 8535 8536 -- at end 8537 -- _clean; 8538 -- end pfunc; 8539 8540 -- procedure entE 8541 -- (O : System.Address; 8542 -- P : System.Address; 8543 -- E : Protected_Entry_Index) 8544 -- is 8545 -- <discriminant renamings> 8546 -- <private object renamings> 8547 -- type poVP is access poV; 8548 -- _Object : ptVP := ptVP!(O); 8549 8550 -- begin 8551 -- begin 8552 -- <statement sequence> 8553 -- Complete_Entry_Body (_Object._Object); 8554 -- exception 8555 -- when all others => 8556 -- Exceptional_Complete_Entry_Body ( 8557 -- _Object._Object, Get_GNAT_Exception); 8558 -- end; 8559 -- end entE; 8560 8561 -- The type poV is the record created for the protected type to hold 8562 -- the state of the protected object. 8563 8564 procedure Expand_N_Protected_Body (N : Node_Id) is 8565 Loc : constant Source_Ptr := Sloc (N); 8566 Pid : constant Entity_Id := Corresponding_Spec (N); 8567 8568 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid); 8569 -- This flag indicates whether the lock free implementation is active 8570 8571 Current_Node : Node_Id; 8572 Disp_Op_Body : Node_Id; 8573 New_Op_Body : Node_Id; 8574 Op_Body : Node_Id; 8575 Op_Id : Entity_Id; 8576 8577 function Build_Dispatching_Subprogram_Body 8578 (N : Node_Id; 8579 Pid : Node_Id; 8580 Prot_Bod : Node_Id) return Node_Id; 8581 -- Build a dispatching version of the protected subprogram body. The 8582 -- newly generated subprogram contains a call to the original protected 8583 -- body. The following code is generated: 8584 -- 8585 -- function <protected-function-name> (Param1 .. ParamN) return 8586 -- <return-type> is 8587 -- begin 8588 -- return <protected-function-name>P (Param1 .. ParamN); 8589 -- end <protected-function-name>; 8590 -- 8591 -- or 8592 -- 8593 -- procedure <protected-procedure-name> (Param1 .. ParamN) is 8594 -- begin 8595 -- <protected-procedure-name>P (Param1 .. ParamN); 8596 -- end <protected-procedure-name> 8597 8598 --------------------------------------- 8599 -- Build_Dispatching_Subprogram_Body -- 8600 --------------------------------------- 8601 8602 function Build_Dispatching_Subprogram_Body 8603 (N : Node_Id; 8604 Pid : Node_Id; 8605 Prot_Bod : Node_Id) return Node_Id 8606 is 8607 Loc : constant Source_Ptr := Sloc (N); 8608 Actuals : List_Id; 8609 Formal : Node_Id; 8610 Spec : Node_Id; 8611 Stmts : List_Id; 8612 8613 begin 8614 -- Generate a specification without a letter suffix in order to 8615 -- override an interface function or procedure. 8616 8617 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode); 8618 8619 -- The formal parameters become the actuals of the protected function 8620 -- or procedure call. 8621 8622 Actuals := New_List; 8623 Formal := First (Parameter_Specifications (Spec)); 8624 while Present (Formal) loop 8625 Append_To (Actuals, 8626 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 8627 Next (Formal); 8628 end loop; 8629 8630 if Nkind (Spec) = N_Procedure_Specification then 8631 Stmts := 8632 New_List ( 8633 Make_Procedure_Call_Statement (Loc, 8634 Name => 8635 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8636 Parameter_Associations => Actuals)); 8637 8638 else 8639 pragma Assert (Nkind (Spec) = N_Function_Specification); 8640 8641 Stmts := 8642 New_List ( 8643 Make_Simple_Return_Statement (Loc, 8644 Expression => 8645 Make_Function_Call (Loc, 8646 Name => 8647 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8648 Parameter_Associations => Actuals))); 8649 end if; 8650 8651 return 8652 Make_Subprogram_Body (Loc, 8653 Declarations => Empty_List, 8654 Specification => Spec, 8655 Handled_Statement_Sequence => 8656 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 8657 end Build_Dispatching_Subprogram_Body; 8658 8659 -- Start of processing for Expand_N_Protected_Body 8660 8661 begin 8662 if No_Run_Time_Mode then 8663 Error_Msg_CRT ("protected body", N); 8664 return; 8665 end if; 8666 8667 -- This is the proper body corresponding to a stub. The declarations 8668 -- must be inserted at the point of the stub, which in turn is in the 8669 -- declarative part of the parent unit. 8670 8671 if Nkind (Parent (N)) = N_Subunit then 8672 Current_Node := Corresponding_Stub (Parent (N)); 8673 else 8674 Current_Node := N; 8675 end if; 8676 8677 Op_Body := First (Declarations (N)); 8678 8679 -- The protected body is replaced with the bodies of its protected 8680 -- operations, and the declarations for internal objects that may 8681 -- have been created for entry family bounds. 8682 8683 Rewrite (N, Make_Null_Statement (Sloc (N))); 8684 Analyze (N); 8685 8686 while Present (Op_Body) loop 8687 case Nkind (Op_Body) is 8688 when N_Subprogram_Declaration => 8689 null; 8690 8691 when N_Subprogram_Body => 8692 8693 -- Do not create bodies for eliminated operations 8694 8695 if not Is_Eliminated (Defining_Entity (Op_Body)) 8696 and then not Is_Eliminated (Corresponding_Spec (Op_Body)) 8697 then 8698 if Lock_Free_Active then 8699 New_Op_Body := 8700 Build_Lock_Free_Unprotected_Subprogram_Body 8701 (Op_Body, Pid); 8702 else 8703 New_Op_Body := 8704 Build_Unprotected_Subprogram_Body (Op_Body, Pid); 8705 end if; 8706 8707 Insert_After (Current_Node, New_Op_Body); 8708 Current_Node := New_Op_Body; 8709 Analyze (New_Op_Body); 8710 8711 -- Build the corresponding protected operation. It may 8712 -- appear that this is needed only if this is a visible 8713 -- operation of the type, or if it is an interrupt handler, 8714 -- and this was the strategy used previously in GNAT. 8715 8716 -- However, the operation may be exported through a 'Access 8717 -- to an external caller. This is the common idiom in code 8718 -- that uses the Ada 2005 Timing_Events package. As a result 8719 -- we need to produce the protected body for both visible 8720 -- and private operations, as well as operations that only 8721 -- have a body in the source, and for which we create a 8722 -- declaration in the protected body itself. 8723 8724 if Present (Corresponding_Spec (Op_Body)) then 8725 if Lock_Free_Active then 8726 New_Op_Body := 8727 Build_Lock_Free_Protected_Subprogram_Body 8728 (Op_Body, Pid, Specification (New_Op_Body)); 8729 else 8730 New_Op_Body := 8731 Build_Protected_Subprogram_Body 8732 (Op_Body, Pid, Specification (New_Op_Body)); 8733 end if; 8734 8735 Insert_After (Current_Node, New_Op_Body); 8736 Analyze (New_Op_Body); 8737 8738 Current_Node := New_Op_Body; 8739 8740 -- Generate an overriding primitive operation body for 8741 -- this subprogram if the protected type implements an 8742 -- interface. 8743 8744 if Ada_Version >= Ada_2005 8745 and then 8746 Present (Interfaces (Corresponding_Record_Type (Pid))) 8747 then 8748 Disp_Op_Body := 8749 Build_Dispatching_Subprogram_Body 8750 (Op_Body, Pid, New_Op_Body); 8751 8752 Insert_After (Current_Node, Disp_Op_Body); 8753 Analyze (Disp_Op_Body); 8754 8755 Current_Node := Disp_Op_Body; 8756 end if; 8757 end if; 8758 end if; 8759 8760 when N_Entry_Body => 8761 Op_Id := Defining_Identifier (Op_Body); 8762 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); 8763 8764 Insert_After (Current_Node, New_Op_Body); 8765 Current_Node := New_Op_Body; 8766 Analyze (New_Op_Body); 8767 8768 when N_Implicit_Label_Declaration => 8769 null; 8770 8771 when N_Call_Marker 8772 | N_Itype_Reference 8773 => 8774 New_Op_Body := New_Copy (Op_Body); 8775 Insert_After (Current_Node, New_Op_Body); 8776 Current_Node := New_Op_Body; 8777 8778 when N_Freeze_Entity => 8779 New_Op_Body := New_Copy (Op_Body); 8780 8781 if Present (Entity (Op_Body)) 8782 and then Freeze_Node (Entity (Op_Body)) = Op_Body 8783 then 8784 Set_Freeze_Node (Entity (Op_Body), New_Op_Body); 8785 end if; 8786 8787 Insert_After (Current_Node, New_Op_Body); 8788 Current_Node := New_Op_Body; 8789 Analyze (New_Op_Body); 8790 8791 when N_Pragma => 8792 New_Op_Body := New_Copy (Op_Body); 8793 Insert_After (Current_Node, New_Op_Body); 8794 Current_Node := New_Op_Body; 8795 Analyze (New_Op_Body); 8796 8797 when N_Object_Declaration => 8798 pragma Assert (not Comes_From_Source (Op_Body)); 8799 New_Op_Body := New_Copy (Op_Body); 8800 Insert_After (Current_Node, New_Op_Body); 8801 Current_Node := New_Op_Body; 8802 Analyze (New_Op_Body); 8803 8804 when others => 8805 raise Program_Error; 8806 end case; 8807 8808 Next (Op_Body); 8809 end loop; 8810 8811 -- Finally, create the body of the function that maps an entry index 8812 -- into the corresponding body index, except when there is no entry, or 8813 -- in a Ravenscar-like profile. 8814 8815 if Corresponding_Runtime_Package (Pid) = 8816 System_Tasking_Protected_Objects_Entries 8817 then 8818 New_Op_Body := Build_Find_Body_Index (Pid); 8819 Insert_After (Current_Node, New_Op_Body); 8820 Current_Node := New_Op_Body; 8821 Analyze (New_Op_Body); 8822 end if; 8823 8824 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the 8825 -- protected body. At this point all wrapper specs have been created, 8826 -- frozen and included in the dispatch table for the protected type. 8827 8828 if Ada_Version >= Ada_2005 then 8829 Build_Wrapper_Bodies (Loc, Pid, Current_Node); 8830 end if; 8831 end Expand_N_Protected_Body; 8832 8833 ----------------------------------------- 8834 -- Expand_N_Protected_Type_Declaration -- 8835 ----------------------------------------- 8836 8837 -- First we create a corresponding record type declaration used to 8838 -- represent values of this protected type. 8839 -- The general form of this type declaration is 8840 8841 -- type poV (discriminants) is record 8842 -- _Object : aliased <kind>Protection 8843 -- [(<entry count> [, <handler count>])]; 8844 -- [entry_family : array (bounds) of Void;] 8845 -- <private data fields> 8846 -- end record; 8847 8848 -- The discriminants are present only if the corresponding protected type 8849 -- has discriminants, and they exactly mirror the protected type 8850 -- discriminants. The private data fields similarly mirror the private 8851 -- declarations of the protected type. 8852 8853 -- The Object field is always present. It contains RTS specific data used 8854 -- to control the protected object. It is declared as Aliased so that it 8855 -- can be passed as a pointer to the RTS. This allows the protected record 8856 -- to be referenced within RTS data structures. An appropriate Protection 8857 -- type and discriminant are generated. 8858 8859 -- The Service field is present for protected objects with entries. It 8860 -- contains sufficient information to allow the entry service procedure for 8861 -- this object to be called when the object is not known till runtime. 8862 8863 -- One entry_family component is present for each entry family in the 8864 -- task definition (see Expand_N_Task_Type_Declaration). 8865 8866 -- When a protected object is declared, an instance of the protected type 8867 -- value record is created. The elaboration of this declaration creates the 8868 -- correct bounds for the entry families, and also evaluates the priority 8869 -- expression if needed. The initialization routine for the protected type 8870 -- itself then calls Initialize_Protection with appropriate parameters to 8871 -- initialize the value of the Task_Id field. Install_Handlers may be also 8872 -- called if a pragma Attach_Handler applies. 8873 8874 -- Note: this record is passed to the subprograms created by the expansion 8875 -- of protected subprograms and entries. It is an in parameter to protected 8876 -- functions and an in out parameter to procedures and entry bodies. The 8877 -- Entity_Id for this created record type is placed in the 8878 -- Corresponding_Record_Type field of the associated protected type entity. 8879 8880 -- Next we create a procedure specifications for protected subprograms and 8881 -- entry bodies. For each protected subprograms two subprograms are 8882 -- created, an unprotected and a protected version. The unprotected version 8883 -- is called from within other operations of the same protected object. 8884 8885 -- We also build the call to register the procedure if a pragma 8886 -- Interrupt_Handler applies. 8887 8888 -- A single subprogram is created to service all entry bodies; it has an 8889 -- additional boolean out parameter indicating that the previous entry call 8890 -- made by the current task was serviced immediately, i.e. not by proxy. 8891 -- The O parameter contains a pointer to a record object of the type 8892 -- described above. An untyped interface is used here to allow this 8893 -- procedure to be called in places where the type of the object to be 8894 -- serviced is not known. This must be done, for example, when a call that 8895 -- may have been requeued is cancelled; the corresponding object must be 8896 -- serviced, but which object that is not known till runtime. 8897 8898 -- procedure ptypeS 8899 -- (O : System.Address; P : out Boolean); 8900 -- procedure pprocN (_object : in out poV); 8901 -- procedure pproc (_object : in out poV); 8902 -- function pfuncN (_object : poV); 8903 -- function pfunc (_object : poV); 8904 -- ... 8905 8906 -- Note that this must come after the record type declaration, since 8907 -- the specs refer to this type. 8908 8909 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is 8910 Discr_Map : constant Elist_Id := New_Elmt_List; 8911 Loc : constant Source_Ptr := Sloc (N); 8912 Prot_Typ : constant Entity_Id := Defining_Identifier (N); 8913 8914 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ); 8915 -- This flag indicates whether the lock free implementation is active 8916 8917 Pdef : constant Node_Id := Protected_Definition (N); 8918 -- This contains two lists; one for visible and one for private decls 8919 8920 Current_Node : Node_Id := N; 8921 E_Count : Int; 8922 Entries_Aggr : Node_Id; 8923 8924 procedure Check_Inlining (Subp : Entity_Id); 8925 -- If the original operation has a pragma Inline, propagate the flag 8926 -- to the internal body, for possible inlining later on. The source 8927 -- operation is invisible to the back-end and is never actually called. 8928 8929 procedure Expand_Entry_Declaration (Decl : Node_Id); 8930 -- Create the entry barrier and the procedure body for entry declaration 8931 -- Decl. All generated subprograms are added to Entry_Bodies_Array. 8932 8933 function Static_Component_Size (Comp : Entity_Id) return Boolean; 8934 -- When compiling under the Ravenscar profile, private components must 8935 -- have a static size, or else a protected object will require heap 8936 -- allocation, violating the corresponding restriction. It is preferable 8937 -- to make this check here, because it provides a better error message 8938 -- than the back-end, which refers to the object as a whole. 8939 8940 procedure Register_Handler; 8941 -- For a protected operation that is an interrupt handler, add the 8942 -- freeze action that will register it as such. 8943 8944 -------------------- 8945 -- Check_Inlining -- 8946 -------------------- 8947 8948 procedure Check_Inlining (Subp : Entity_Id) is 8949 begin 8950 if Is_Inlined (Subp) then 8951 Set_Is_Inlined (Protected_Body_Subprogram (Subp)); 8952 Set_Is_Inlined (Subp, False); 8953 end if; 8954 end Check_Inlining; 8955 8956 --------------------------- 8957 -- Static_Component_Size -- 8958 --------------------------- 8959 8960 function Static_Component_Size (Comp : Entity_Id) return Boolean is 8961 Typ : constant Entity_Id := Etype (Comp); 8962 C : Entity_Id; 8963 8964 begin 8965 if Is_Scalar_Type (Typ) then 8966 return True; 8967 8968 elsif Is_Array_Type (Typ) then 8969 return Compile_Time_Known_Bounds (Typ); 8970 8971 elsif Is_Record_Type (Typ) then 8972 C := First_Component (Typ); 8973 while Present (C) loop 8974 if not Static_Component_Size (C) then 8975 return False; 8976 end if; 8977 8978 Next_Component (C); 8979 end loop; 8980 8981 return True; 8982 8983 -- Any other type will be checked by the back-end 8984 8985 else 8986 return True; 8987 end if; 8988 end Static_Component_Size; 8989 8990 ------------------------------ 8991 -- Expand_Entry_Declaration -- 8992 ------------------------------ 8993 8994 procedure Expand_Entry_Declaration (Decl : Node_Id) is 8995 Ent_Id : constant Entity_Id := Defining_Entity (Decl); 8996 Bar_Id : Entity_Id; 8997 Bod_Id : Entity_Id; 8998 Subp : Node_Id; 8999 9000 begin 9001 E_Count := E_Count + 1; 9002 9003 -- Create the protected body subprogram 9004 9005 Bod_Id := 9006 Make_Defining_Identifier (Loc, 9007 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E')); 9008 Set_Protected_Body_Subprogram (Ent_Id, Bod_Id); 9009 9010 Subp := 9011 Make_Subprogram_Declaration (Loc, 9012 Specification => 9013 Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id)); 9014 9015 Insert_After (Current_Node, Subp); 9016 Current_Node := Subp; 9017 9018 Analyze (Subp); 9019 9020 -- Build a wrapper procedure to handle contract cases, preconditions, 9021 -- and postconditions. 9022 9023 Build_Contract_Wrapper (Ent_Id, N); 9024 9025 -- Create the barrier function 9026 9027 Bar_Id := 9028 Make_Defining_Identifier (Loc, 9029 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B')); 9030 Set_Barrier_Function (Ent_Id, Bar_Id); 9031 9032 Subp := 9033 Make_Subprogram_Declaration (Loc, 9034 Specification => 9035 Build_Barrier_Function_Specification (Loc, Bar_Id)); 9036 Set_Is_Entry_Barrier_Function (Subp); 9037 9038 Insert_After (Current_Node, Subp); 9039 Current_Node := Subp; 9040 9041 Analyze (Subp); 9042 9043 Set_Protected_Body_Subprogram (Bar_Id, Bar_Id); 9044 Set_Scope (Bar_Id, Scope (Ent_Id)); 9045 9046 -- Collect pointers to the protected subprogram and the barrier 9047 -- of the current entry, for insertion into Entry_Bodies_Array. 9048 9049 Append_To (Expressions (Entries_Aggr), 9050 Make_Aggregate (Loc, 9051 Expressions => New_List ( 9052 Make_Attribute_Reference (Loc, 9053 Prefix => New_Occurrence_Of (Bar_Id, Loc), 9054 Attribute_Name => Name_Unrestricted_Access), 9055 Make_Attribute_Reference (Loc, 9056 Prefix => New_Occurrence_Of (Bod_Id, Loc), 9057 Attribute_Name => Name_Unrestricted_Access)))); 9058 end Expand_Entry_Declaration; 9059 9060 ---------------------- 9061 -- Register_Handler -- 9062 ---------------------- 9063 9064 procedure Register_Handler is 9065 9066 -- All semantic checks already done in Sem_Prag 9067 9068 Prot_Proc : constant Entity_Id := 9069 Defining_Unit_Name (Specification (Current_Node)); 9070 9071 Proc_Address : constant Node_Id := 9072 Make_Attribute_Reference (Loc, 9073 Prefix => 9074 New_Occurrence_Of (Prot_Proc, Loc), 9075 Attribute_Name => Name_Address); 9076 9077 RTS_Call : constant Entity_Id := 9078 Make_Procedure_Call_Statement (Loc, 9079 Name => 9080 New_Occurrence_Of 9081 (RTE (RE_Register_Interrupt_Handler), Loc), 9082 Parameter_Associations => New_List (Proc_Address)); 9083 begin 9084 Append_Freeze_Action (Prot_Proc, RTS_Call); 9085 end Register_Handler; 9086 9087 -- Local variables 9088 9089 Body_Arr : Node_Id; 9090 Body_Id : Entity_Id; 9091 Cdecls : List_Id; 9092 Comp : Node_Id; 9093 Expr : Node_Id; 9094 New_Priv : Node_Id; 9095 Obj_Def : Node_Id; 9096 Object_Comp : Node_Id; 9097 Priv : Node_Id; 9098 Rec_Decl : Node_Id; 9099 Sub : Node_Id; 9100 9101 -- Start of processing for Expand_N_Protected_Type_Declaration 9102 9103 begin 9104 if Present (Corresponding_Record_Type (Prot_Typ)) then 9105 return; 9106 else 9107 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); 9108 end if; 9109 9110 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); 9111 9112 Qualify_Entity_Names (N); 9113 9114 -- If the type has discriminants, their occurrences in the declaration 9115 -- have been replaced by the corresponding discriminals. For components 9116 -- that are constrained by discriminants, their homologues in the 9117 -- corresponding record type must refer to the discriminants of that 9118 -- record, so we must apply a new renaming to subtypes_indications: 9119 9120 -- protected discriminant => discriminal => record discriminant 9121 9122 -- This replacement is not applied to default expressions, for which 9123 -- the discriminal is correct. 9124 9125 if Has_Discriminants (Prot_Typ) then 9126 declare 9127 Disc : Entity_Id; 9128 Decl : Node_Id; 9129 9130 begin 9131 Disc := First_Discriminant (Prot_Typ); 9132 Decl := First (Discriminant_Specifications (Rec_Decl)); 9133 while Present (Disc) loop 9134 Append_Elmt (Discriminal (Disc), Discr_Map); 9135 Append_Elmt (Defining_Identifier (Decl), Discr_Map); 9136 Next_Discriminant (Disc); 9137 Next (Decl); 9138 end loop; 9139 end; 9140 end if; 9141 9142 -- Fill in the component declarations 9143 9144 -- Add components for entry families. For each entry family, create an 9145 -- anonymous type declaration with the same size, and analyze the type. 9146 9147 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); 9148 9149 pragma Assert (Present (Pdef)); 9150 9151 Insert_After (Current_Node, Rec_Decl); 9152 Current_Node := Rec_Decl; 9153 9154 -- Add private field components 9155 9156 if Present (Private_Declarations (Pdef)) then 9157 Priv := First (Private_Declarations (Pdef)); 9158 while Present (Priv) loop 9159 if Nkind (Priv) = N_Component_Declaration then 9160 if not Static_Component_Size (Defining_Identifier (Priv)) then 9161 9162 -- When compiling for a restricted profile, the private 9163 -- components must have a static size. If not, this is an 9164 -- error for a single protected declaration, and rates a 9165 -- warning on a protected type declaration. 9166 9167 if not Comes_From_Source (Prot_Typ) then 9168 9169 -- It's ok to be checking this restriction at expansion 9170 -- time, because this is only for the restricted profile, 9171 -- which is not subject to strict RM conformance, so it 9172 -- is OK to miss this check in -gnatc mode. 9173 9174 Check_Restriction (No_Implicit_Heap_Allocations, Priv); 9175 Check_Restriction 9176 (No_Implicit_Protected_Object_Allocations, Priv); 9177 9178 elsif Restriction_Active (No_Implicit_Heap_Allocations) then 9179 if not Discriminated_Size (Defining_Identifier (Priv)) 9180 then 9181 -- Any object of the type will be non-static 9182 9183 Error_Msg_N ("component has non-static size??", Priv); 9184 Error_Msg_NE 9185 ("\creation of protected object of type& will " 9186 & "violate restriction " 9187 & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ); 9188 else 9189 -- Object will be non-static if discriminants are 9190 9191 Error_Msg_NE 9192 ("creation of protected object of type& with " 9193 & "non-static discriminants will violate " 9194 & "restriction No_Implicit_Heap_Allocations??", 9195 Priv, Prot_Typ); 9196 end if; 9197 9198 -- Likewise for No_Implicit_Protected_Object_Allocations 9199 9200 elsif Restriction_Active 9201 (No_Implicit_Protected_Object_Allocations) 9202 then 9203 if not Discriminated_Size (Defining_Identifier (Priv)) 9204 then 9205 -- Any object of the type will be non-static 9206 9207 Error_Msg_N ("component has non-static size??", Priv); 9208 Error_Msg_NE 9209 ("\creation of protected object of type& will " 9210 & "violate restriction " 9211 & "No_Implicit_Protected_Object_Allocations??", 9212 Priv, Prot_Typ); 9213 else 9214 -- Object will be non-static if discriminants are 9215 9216 Error_Msg_NE 9217 ("creation of protected object of type& with " 9218 & "non-static discriminants will violate " 9219 & "restriction " 9220 & "No_Implicit_Protected_Object_Allocations??", 9221 Priv, Prot_Typ); 9222 end if; 9223 end if; 9224 end if; 9225 9226 -- The component definition consists of a subtype indication, 9227 -- or (in Ada 2005) an access definition. Make a copy of the 9228 -- proper definition. 9229 9230 declare 9231 Old_Comp : constant Node_Id := Component_Definition (Priv); 9232 Oent : constant Entity_Id := Defining_Identifier (Priv); 9233 Nent : constant Entity_Id := 9234 Make_Defining_Identifier (Sloc (Oent), 9235 Chars => Chars (Oent)); 9236 New_Comp : Node_Id; 9237 9238 begin 9239 if Present (Subtype_Indication (Old_Comp)) then 9240 New_Comp := 9241 Make_Component_Definition (Sloc (Oent), 9242 Aliased_Present => False, 9243 Subtype_Indication => 9244 New_Copy_Tree 9245 (Subtype_Indication (Old_Comp), Discr_Map)); 9246 else 9247 New_Comp := 9248 Make_Component_Definition (Sloc (Oent), 9249 Aliased_Present => False, 9250 Access_Definition => 9251 New_Copy_Tree 9252 (Access_Definition (Old_Comp), Discr_Map)); 9253 end if; 9254 9255 New_Priv := 9256 Make_Component_Declaration (Loc, 9257 Defining_Identifier => Nent, 9258 Component_Definition => New_Comp, 9259 Expression => Expression (Priv)); 9260 9261 Set_Has_Per_Object_Constraint (Nent, 9262 Has_Per_Object_Constraint (Oent)); 9263 9264 Append_To (Cdecls, New_Priv); 9265 end; 9266 9267 elsif Nkind (Priv) = N_Subprogram_Declaration then 9268 9269 -- Make the unprotected version of the subprogram available 9270 -- for expansion of intra object calls. There is need for 9271 -- a protected version only if the subprogram is an interrupt 9272 -- handler, otherwise this operation can only be called from 9273 -- within the body. 9274 9275 Sub := 9276 Make_Subprogram_Declaration (Loc, 9277 Specification => 9278 Build_Protected_Sub_Specification 9279 (Priv, Prot_Typ, Unprotected_Mode)); 9280 9281 Insert_After (Current_Node, Sub); 9282 Analyze (Sub); 9283 9284 Set_Protected_Body_Subprogram 9285 (Defining_Unit_Name (Specification (Priv)), 9286 Defining_Unit_Name (Specification (Sub))); 9287 Check_Inlining (Defining_Unit_Name (Specification (Priv))); 9288 Current_Node := Sub; 9289 9290 Sub := 9291 Make_Subprogram_Declaration (Loc, 9292 Specification => 9293 Build_Protected_Sub_Specification 9294 (Priv, Prot_Typ, Protected_Mode)); 9295 9296 Insert_After (Current_Node, Sub); 9297 Analyze (Sub); 9298 Current_Node := Sub; 9299 9300 if Is_Interrupt_Handler 9301 (Defining_Unit_Name (Specification (Priv))) 9302 then 9303 if not Restricted_Profile then 9304 Register_Handler; 9305 end if; 9306 end if; 9307 end if; 9308 9309 Next (Priv); 9310 end loop; 9311 end if; 9312 9313 -- Except for the lock-free implementation, append the _Object field 9314 -- with the right type to the component list. We need to compute the 9315 -- number of entries, and in some cases the number of Attach_Handler 9316 -- pragmas. 9317 9318 if not Lock_Free_Active then 9319 declare 9320 Entry_Count_Expr : constant Node_Id := 9321 Build_Entry_Count_Expression 9322 (Prot_Typ, Cdecls, Loc); 9323 Num_Attach_Handler : Nat := 0; 9324 Protection_Subtype : Node_Id; 9325 Ritem : Node_Id; 9326 9327 begin 9328 if Has_Attach_Handler (Prot_Typ) then 9329 Ritem := First_Rep_Item (Prot_Typ); 9330 while Present (Ritem) loop 9331 if Nkind (Ritem) = N_Pragma 9332 and then Pragma_Name (Ritem) = Name_Attach_Handler 9333 then 9334 Num_Attach_Handler := Num_Attach_Handler + 1; 9335 end if; 9336 9337 Next_Rep_Item (Ritem); 9338 end loop; 9339 end if; 9340 9341 -- Determine the proper protection type. There are two special 9342 -- cases: 1) when the protected type has dynamic interrupt 9343 -- handlers, and 2) when it has static handlers and we use a 9344 -- restricted profile. 9345 9346 if Has_Attach_Handler (Prot_Typ) 9347 and then not Restricted_Profile 9348 then 9349 Protection_Subtype := 9350 Make_Subtype_Indication (Loc, 9351 Subtype_Mark => 9352 New_Occurrence_Of 9353 (RTE (RE_Static_Interrupt_Protection), Loc), 9354 Constraint => 9355 Make_Index_Or_Discriminant_Constraint (Loc, 9356 Constraints => New_List ( 9357 Entry_Count_Expr, 9358 Make_Integer_Literal (Loc, Num_Attach_Handler)))); 9359 9360 elsif Has_Interrupt_Handler (Prot_Typ) 9361 and then not Restriction_Active (No_Dynamic_Attachment) 9362 then 9363 Protection_Subtype := 9364 Make_Subtype_Indication (Loc, 9365 Subtype_Mark => 9366 New_Occurrence_Of 9367 (RTE (RE_Dynamic_Interrupt_Protection), Loc), 9368 Constraint => 9369 Make_Index_Or_Discriminant_Constraint (Loc, 9370 Constraints => New_List (Entry_Count_Expr))); 9371 9372 else 9373 case Corresponding_Runtime_Package (Prot_Typ) is 9374 when System_Tasking_Protected_Objects_Entries => 9375 Protection_Subtype := 9376 Make_Subtype_Indication (Loc, 9377 Subtype_Mark => 9378 New_Occurrence_Of 9379 (RTE (RE_Protection_Entries), Loc), 9380 Constraint => 9381 Make_Index_Or_Discriminant_Constraint (Loc, 9382 Constraints => New_List (Entry_Count_Expr))); 9383 9384 when System_Tasking_Protected_Objects_Single_Entry => 9385 Protection_Subtype := 9386 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc); 9387 9388 when System_Tasking_Protected_Objects => 9389 Protection_Subtype := 9390 New_Occurrence_Of (RTE (RE_Protection), Loc); 9391 9392 when others => 9393 raise Program_Error; 9394 end case; 9395 end if; 9396 9397 Object_Comp := 9398 Make_Component_Declaration (Loc, 9399 Defining_Identifier => 9400 Make_Defining_Identifier (Loc, Name_uObject), 9401 Component_Definition => 9402 Make_Component_Definition (Loc, 9403 Aliased_Present => True, 9404 Subtype_Indication => Protection_Subtype)); 9405 end; 9406 9407 -- Put the _Object component after the private component so that it 9408 -- be finalized early as required by 9.4 (20) 9409 9410 Append_To (Cdecls, Object_Comp); 9411 end if; 9412 9413 -- Analyze the record declaration immediately after construction, 9414 -- because the initialization procedure is needed for single object 9415 -- declarations before the next entity is analyzed (the freeze call 9416 -- that generates this initialization procedure is found below). 9417 9418 Analyze (Rec_Decl, Suppress => All_Checks); 9419 9420 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before 9421 -- the corresponding record is frozen. If any wrappers are generated, 9422 -- Current_Node is updated accordingly. 9423 9424 if Ada_Version >= Ada_2005 then 9425 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node); 9426 end if; 9427 9428 -- Collect pointers to entry bodies and their barriers, to be placed 9429 -- in the Entry_Bodies_Array for the type. For each entry/family we 9430 -- add an expression to the aggregate which is the initial value of 9431 -- this array. The array is declared after all protected subprograms. 9432 9433 if Has_Entries (Prot_Typ) then 9434 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); 9435 else 9436 Entries_Aggr := Empty; 9437 end if; 9438 9439 -- Build two new procedure specifications for each protected subprogram; 9440 -- one to call from outside the object and one to call from inside. 9441 -- Build a barrier function and an entry body action procedure 9442 -- specification for each protected entry. Initialize the entry body 9443 -- array. If subprogram is flagged as eliminated, do not generate any 9444 -- internal operations. 9445 9446 E_Count := 0; 9447 Comp := First (Visible_Declarations (Pdef)); 9448 while Present (Comp) loop 9449 if Nkind (Comp) = N_Subprogram_Declaration then 9450 Sub := 9451 Make_Subprogram_Declaration (Loc, 9452 Specification => 9453 Build_Protected_Sub_Specification 9454 (Comp, Prot_Typ, Unprotected_Mode)); 9455 9456 Insert_After (Current_Node, Sub); 9457 Analyze (Sub); 9458 9459 Set_Protected_Body_Subprogram 9460 (Defining_Unit_Name (Specification (Comp)), 9461 Defining_Unit_Name (Specification (Sub))); 9462 Check_Inlining (Defining_Unit_Name (Specification (Comp))); 9463 9464 -- Make the protected version of the subprogram available for 9465 -- expansion of external calls. 9466 9467 Current_Node := Sub; 9468 9469 Sub := 9470 Make_Subprogram_Declaration (Loc, 9471 Specification => 9472 Build_Protected_Sub_Specification 9473 (Comp, Prot_Typ, Protected_Mode)); 9474 9475 Insert_After (Current_Node, Sub); 9476 Analyze (Sub); 9477 9478 Current_Node := Sub; 9479 9480 -- Generate an overriding primitive operation specification for 9481 -- this subprogram if the protected type implements an interface 9482 -- and Build_Wrapper_Spec did not generate its wrapper. 9483 9484 if Ada_Version >= Ada_2005 9485 and then 9486 Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) 9487 then 9488 declare 9489 Found : Boolean := False; 9490 Prim_Elmt : Elmt_Id; 9491 Prim_Op : Node_Id; 9492 9493 begin 9494 Prim_Elmt := 9495 First_Elmt 9496 (Primitive_Operations 9497 (Corresponding_Record_Type (Prot_Typ))); 9498 9499 while Present (Prim_Elmt) loop 9500 Prim_Op := Node (Prim_Elmt); 9501 9502 if Is_Primitive_Wrapper (Prim_Op) 9503 and then Wrapped_Entity (Prim_Op) = 9504 Defining_Entity (Specification (Comp)) 9505 then 9506 Found := True; 9507 exit; 9508 end if; 9509 9510 Next_Elmt (Prim_Elmt); 9511 end loop; 9512 9513 if not Found then 9514 Sub := 9515 Make_Subprogram_Declaration (Loc, 9516 Specification => 9517 Build_Protected_Sub_Specification 9518 (Comp, Prot_Typ, Dispatching_Mode)); 9519 9520 Insert_After (Current_Node, Sub); 9521 Analyze (Sub); 9522 9523 Current_Node := Sub; 9524 end if; 9525 end; 9526 end if; 9527 9528 -- If a pragma Interrupt_Handler applies, build and add a call to 9529 -- Register_Interrupt_Handler to the freezing actions of the 9530 -- protected version (Current_Node) of the subprogram: 9531 9532 -- system.interrupts.register_interrupt_handler 9533 -- (prot_procP'address); 9534 9535 if not Restricted_Profile 9536 and then Is_Interrupt_Handler 9537 (Defining_Unit_Name (Specification (Comp))) 9538 then 9539 Register_Handler; 9540 end if; 9541 9542 elsif Nkind (Comp) = N_Entry_Declaration then 9543 Expand_Entry_Declaration (Comp); 9544 end if; 9545 9546 Next (Comp); 9547 end loop; 9548 9549 -- If there are some private entry declarations, expand it as if they 9550 -- were visible entries. 9551 9552 if Present (Private_Declarations (Pdef)) then 9553 Comp := First (Private_Declarations (Pdef)); 9554 while Present (Comp) loop 9555 if Nkind (Comp) = N_Entry_Declaration then 9556 Expand_Entry_Declaration (Comp); 9557 end if; 9558 9559 Next (Comp); 9560 end loop; 9561 end if; 9562 9563 -- Create the declaration of an array object which contains the values 9564 -- of aspect/pragma Max_Queue_Length for all entries of the protected 9565 -- type. This object is later passed to the appropriate protected object 9566 -- initialization routine. 9567 9568 if Has_Entries (Prot_Typ) 9569 and then Corresponding_Runtime_Package (Prot_Typ) = 9570 System_Tasking_Protected_Objects_Entries 9571 then 9572 declare 9573 Count : Int; 9574 Item : Entity_Id; 9575 Max_Vals : Node_Id; 9576 Maxes : List_Id; 9577 Maxes_Id : Entity_Id; 9578 Need_Array : Boolean := False; 9579 9580 begin 9581 -- First check if there is any Max_Queue_Length pragma 9582 9583 Item := First_Entity (Prot_Typ); 9584 while Present (Item) loop 9585 if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then 9586 Need_Array := True; 9587 exit; 9588 end if; 9589 9590 Next_Entity (Item); 9591 end loop; 9592 9593 -- Gather the Max_Queue_Length values of all entries in a list. A 9594 -- value of zero indicates that the entry has no limitation on its 9595 -- queue length. 9596 9597 if Need_Array then 9598 Count := 0; 9599 Item := First_Entity (Prot_Typ); 9600 Maxes := New_List; 9601 while Present (Item) loop 9602 if Is_Entry (Item) then 9603 Count := Count + 1; 9604 Append_To (Maxes, 9605 Make_Integer_Literal 9606 (Loc, Get_Max_Queue_Length (Item))); 9607 end if; 9608 9609 Next_Entity (Item); 9610 end loop; 9611 9612 -- Create the declaration of the array object. Generate: 9613 9614 -- Maxes_Id : aliased constant 9615 -- Protected_Entry_Queue_Max_Array 9616 -- (1 .. Count) := (..., ...); 9617 9618 Maxes_Id := 9619 Make_Defining_Identifier (Loc, 9620 Chars => New_External_Name (Chars (Prot_Typ), 'B')); 9621 9622 Max_Vals := 9623 Make_Object_Declaration (Loc, 9624 Defining_Identifier => Maxes_Id, 9625 Aliased_Present => True, 9626 Constant_Present => True, 9627 Object_Definition => 9628 Make_Subtype_Indication (Loc, 9629 Subtype_Mark => 9630 New_Occurrence_Of 9631 (RTE (RE_Protected_Entry_Queue_Max_Array), Loc), 9632 Constraint => 9633 Make_Index_Or_Discriminant_Constraint (Loc, 9634 Constraints => New_List ( 9635 Make_Range (Loc, 9636 Make_Integer_Literal (Loc, 1), 9637 Make_Integer_Literal (Loc, Count))))), 9638 Expression => Make_Aggregate (Loc, Maxes)); 9639 9640 -- A pointer to this array will be placed in the corresponding 9641 -- record by its initialization procedure so this needs to be 9642 -- analyzed here. 9643 9644 Insert_After (Current_Node, Max_Vals); 9645 Current_Node := Max_Vals; 9646 Analyze (Max_Vals); 9647 9648 Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxes_Id); 9649 end if; 9650 end; 9651 end if; 9652 9653 -- Emit declaration for Entry_Bodies_Array, now that the addresses of 9654 -- all protected subprograms have been collected. 9655 9656 if Has_Entries (Prot_Typ) then 9657 Body_Id := 9658 Make_Defining_Identifier (Sloc (Prot_Typ), 9659 Chars => New_External_Name (Chars (Prot_Typ), 'A')); 9660 9661 case Corresponding_Runtime_Package (Prot_Typ) is 9662 when System_Tasking_Protected_Objects_Entries => 9663 Expr := Entries_Aggr; 9664 Obj_Def := 9665 Make_Subtype_Indication (Loc, 9666 Subtype_Mark => 9667 New_Occurrence_Of 9668 (RTE (RE_Protected_Entry_Body_Array), Loc), 9669 Constraint => 9670 Make_Index_Or_Discriminant_Constraint (Loc, 9671 Constraints => New_List ( 9672 Make_Range (Loc, 9673 Make_Integer_Literal (Loc, 1), 9674 Make_Integer_Literal (Loc, E_Count))))); 9675 9676 when System_Tasking_Protected_Objects_Single_Entry => 9677 Expr := Remove_Head (Expressions (Entries_Aggr)); 9678 Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc); 9679 9680 when others => 9681 raise Program_Error; 9682 end case; 9683 9684 Body_Arr := 9685 Make_Object_Declaration (Loc, 9686 Defining_Identifier => Body_Id, 9687 Aliased_Present => True, 9688 Constant_Present => True, 9689 Object_Definition => Obj_Def, 9690 Expression => Expr); 9691 9692 -- A pointer to this array will be placed in the corresponding record 9693 -- by its initialization procedure so this needs to be analyzed here. 9694 9695 Insert_After (Current_Node, Body_Arr); 9696 Current_Node := Body_Arr; 9697 Analyze (Body_Arr); 9698 9699 Set_Entry_Bodies_Array (Prot_Typ, Body_Id); 9700 9701 -- Finally, build the function that maps an entry index into the 9702 -- corresponding body. A pointer to this function is placed in each 9703 -- object of the type. Except for a ravenscar-like profile (no abort, 9704 -- no entry queue, 1 entry) 9705 9706 if Corresponding_Runtime_Package (Prot_Typ) = 9707 System_Tasking_Protected_Objects_Entries 9708 then 9709 Sub := 9710 Make_Subprogram_Declaration (Loc, 9711 Specification => Build_Find_Body_Index_Spec (Prot_Typ)); 9712 9713 Insert_After (Current_Node, Sub); 9714 Analyze (Sub); 9715 end if; 9716 end if; 9717 end Expand_N_Protected_Type_Declaration; 9718 9719 -------------------------------- 9720 -- Expand_N_Requeue_Statement -- 9721 -------------------------------- 9722 9723 -- A nondispatching requeue statement is expanded into one of four GNARLI 9724 -- operations, depending on the source and destination (task or protected 9725 -- object). A dispatching requeue statement is expanded into a call to the 9726 -- predefined primitive _Disp_Requeue. In addition, code is generated to 9727 -- jump around the remainder of processing for the original entry and, if 9728 -- the destination is (different) protected object, to attempt to service 9729 -- it. The following illustrates the various cases: 9730 9731 -- procedure entE 9732 -- (O : System.Address; 9733 -- P : System.Address; 9734 -- E : Protected_Entry_Index) 9735 -- is 9736 -- <discriminant renamings> 9737 -- <private object renamings> 9738 -- type poVP is access poV; 9739 -- _object : ptVP := ptVP!(O); 9740 9741 -- begin 9742 -- begin 9743 -- <start of statement sequence for entry> 9744 9745 -- -- Requeue from one protected entry body to another protected 9746 -- -- entry. 9747 9748 -- Requeue_Protected_Entry ( 9749 -- _object._object'Access, 9750 -- new._object'Access, 9751 -- E, 9752 -- Abort_Present); 9753 -- return; 9754 9755 -- <some more of the statement sequence for entry> 9756 9757 -- -- Requeue from an entry body to a task entry 9758 9759 -- Requeue_Protected_To_Task_Entry ( 9760 -- New._task_id, 9761 -- E, 9762 -- Abort_Present); 9763 -- return; 9764 9765 -- <rest of statement sequence for entry> 9766 -- Complete_Entry_Body (_object._object); 9767 9768 -- exception 9769 -- when all others => 9770 -- Exceptional_Complete_Entry_Body ( 9771 -- _object._object, Get_GNAT_Exception); 9772 -- end; 9773 -- end entE; 9774 9775 -- Requeue of a task entry call to a task entry 9776 9777 -- Accept_Call (E, Ann); 9778 -- <start of statement sequence for accept statement> 9779 -- Requeue_Task_Entry (New._task_id, E, Abort_Present); 9780 -- goto Lnn; 9781 -- <rest of statement sequence for accept statement> 9782 -- <<Lnn>> 9783 -- Complete_Rendezvous; 9784 9785 -- exception 9786 -- when all others => 9787 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9788 9789 -- Requeue of a task entry call to a protected entry 9790 9791 -- Accept_Call (E, Ann); 9792 -- <start of statement sequence for accept statement> 9793 -- Requeue_Task_To_Protected_Entry ( 9794 -- new._object'Access, 9795 -- E, 9796 -- Abort_Present); 9797 -- newS (new, Pnn); 9798 -- goto Lnn; 9799 -- <rest of statement sequence for accept statement> 9800 -- <<Lnn>> 9801 -- Complete_Rendezvous; 9802 9803 -- exception 9804 -- when all others => 9805 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9806 9807 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9808 -- marked by pragma Implemented (XXX, By_Entry). 9809 9810 -- The requeue is inside a protected entry: 9811 9812 -- procedure entE 9813 -- (O : System.Address; 9814 -- P : System.Address; 9815 -- E : Protected_Entry_Index) 9816 -- is 9817 -- <discriminant renamings> 9818 -- <private object renamings> 9819 -- type poVP is access poV; 9820 -- _object : ptVP := ptVP!(O); 9821 9822 -- begin 9823 -- begin 9824 -- <start of statement sequence for entry> 9825 9826 -- _Disp_Requeue 9827 -- (<interface class-wide object>, 9828 -- True, 9829 -- _object'Address, 9830 -- Ada.Tags.Get_Offset_Index 9831 -- (Tag (_object), 9832 -- <interface dispatch table index of target entry>), 9833 -- Abort_Present); 9834 -- return; 9835 9836 -- <rest of statement sequence for entry> 9837 -- Complete_Entry_Body (_object._object); 9838 9839 -- exception 9840 -- when all others => 9841 -- Exceptional_Complete_Entry_Body ( 9842 -- _object._object, Get_GNAT_Exception); 9843 -- end; 9844 -- end entE; 9845 9846 -- The requeue is inside a task entry: 9847 9848 -- Accept_Call (E, Ann); 9849 -- <start of statement sequence for accept statement> 9850 -- _Disp_Requeue 9851 -- (<interface class-wide object>, 9852 -- False, 9853 -- null, 9854 -- Ada.Tags.Get_Offset_Index 9855 -- (Tag (_object), 9856 -- <interface dispatch table index of target entrt>), 9857 -- Abort_Present); 9858 -- newS (new, Pnn); 9859 -- goto Lnn; 9860 -- <rest of statement sequence for accept statement> 9861 -- <<Lnn>> 9862 -- Complete_Rendezvous; 9863 9864 -- exception 9865 -- when all others => 9866 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9867 9868 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9869 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue 9870 -- statement is replaced by a dispatching call with actual parameters taken 9871 -- from the inner-most accept statement or entry body. 9872 9873 -- Target.Primitive (Param1, ..., ParamN); 9874 9875 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9876 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked 9877 -- at all. 9878 9879 -- declare 9880 -- S : constant Offset_Index := 9881 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename)); 9882 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S); 9883 9884 -- begin 9885 -- if C = POK_Protected_Entry 9886 -- or else C = POK_Task_Entry 9887 -- then 9888 -- <statements for dispatching requeue> 9889 9890 -- elsif C = POK_Protected_Procedure then 9891 -- <dispatching call equivalent> 9892 9893 -- else 9894 -- raise Program_Error; 9895 -- end if; 9896 -- end; 9897 9898 procedure Expand_N_Requeue_Statement (N : Node_Id) is 9899 Loc : constant Source_Ptr := Sloc (N); 9900 Conc_Typ : Entity_Id; 9901 Concval : Node_Id; 9902 Ename : Node_Id; 9903 Index : Node_Id; 9904 Old_Typ : Entity_Id; 9905 9906 function Build_Dispatching_Call_Equivalent return Node_Id; 9907 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9908 -- the form Concval.Ename. It is statically known that Ename is allowed 9909 -- to be implemented by a protected procedure. Create a dispatching call 9910 -- equivalent of Concval.Ename taking the actual parameters from the 9911 -- inner-most accept statement or entry body. 9912 9913 function Build_Dispatching_Requeue return Node_Id; 9914 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9915 -- the form Concval.Ename. It is statically known that Ename is allowed 9916 -- to be implemented by a protected or a task entry. Create a call to 9917 -- primitive _Disp_Requeue which handles the low-level actions. 9918 9919 function Build_Dispatching_Requeue_To_Any return Node_Id; 9920 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9921 -- the form Concval.Ename. Ename is either marked by pragma Implemented 9922 -- (XXX, By_Any | Optional) or not marked at all. Create a block which 9923 -- determines at runtime whether Ename denotes an entry or a procedure 9924 -- and perform the appropriate kind of dispatching select. 9925 9926 function Build_Normal_Requeue return Node_Id; 9927 -- N denotes a nondispatching requeue statement to either a task or a 9928 -- protected entry. Build the appropriate runtime call to perform the 9929 -- action. 9930 9931 function Build_Skip_Statement (Search : Node_Id) return Node_Id; 9932 -- For a protected entry, create a return statement to skip the rest of 9933 -- the entry body. Otherwise, create a goto statement to skip the rest 9934 -- of a task accept statement. The lookup for the enclosing entry body 9935 -- or accept statement starts from Search. 9936 9937 --------------------------------------- 9938 -- Build_Dispatching_Call_Equivalent -- 9939 --------------------------------------- 9940 9941 function Build_Dispatching_Call_Equivalent return Node_Id is 9942 Call_Ent : constant Entity_Id := Entity (Ename); 9943 Obj : constant Node_Id := Original_Node (Concval); 9944 Acc_Ent : Node_Id; 9945 Actuals : List_Id; 9946 Formal : Node_Id; 9947 Formals : List_Id; 9948 9949 begin 9950 -- Climb the parent chain looking for the inner-most entry body or 9951 -- accept statement. 9952 9953 Acc_Ent := N; 9954 while Present (Acc_Ent) 9955 and then not Nkind_In (Acc_Ent, N_Accept_Statement, 9956 N_Entry_Body) 9957 loop 9958 Acc_Ent := Parent (Acc_Ent); 9959 end loop; 9960 9961 -- A requeue statement should be housed inside an entry body or an 9962 -- accept statement at some level. If this is not the case, then the 9963 -- tree is malformed. 9964 9965 pragma Assert (Present (Acc_Ent)); 9966 9967 -- Recover the list of formal parameters 9968 9969 if Nkind (Acc_Ent) = N_Entry_Body then 9970 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent); 9971 end if; 9972 9973 Formals := Parameter_Specifications (Acc_Ent); 9974 9975 -- Create the actual parameters for the dispatching call. These are 9976 -- simply copies of the entry body or accept statement formals in the 9977 -- same order as they appear. 9978 9979 Actuals := No_List; 9980 9981 if Present (Formals) then 9982 Actuals := New_List; 9983 Formal := First (Formals); 9984 while Present (Formal) loop 9985 Append_To (Actuals, 9986 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 9987 Next (Formal); 9988 end loop; 9989 end if; 9990 9991 -- Generate: 9992 -- Obj.Call_Ent (Actuals); 9993 9994 return 9995 Make_Procedure_Call_Statement (Loc, 9996 Name => 9997 Make_Selected_Component (Loc, 9998 Prefix => Make_Identifier (Loc, Chars (Obj)), 9999 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))), 10000 10001 Parameter_Associations => Actuals); 10002 end Build_Dispatching_Call_Equivalent; 10003 10004 ------------------------------- 10005 -- Build_Dispatching_Requeue -- 10006 ------------------------------- 10007 10008 function Build_Dispatching_Requeue return Node_Id is 10009 Params : constant List_Id := New_List; 10010 10011 begin 10012 -- Process the "with abort" parameter 10013 10014 Prepend_To (Params, 10015 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10016 10017 -- Process the entry wrapper's position in the primary dispatch 10018 -- table parameter. Generate: 10019 10020 -- Ada.Tags.Get_Entry_Index 10021 -- (T => To_Tag_Ptr (Obj'Address).all, 10022 -- Position => 10023 -- Ada.Tags.Get_Offset_Index 10024 -- (Ada.Tags.Tag (Concval), 10025 -- <interface dispatch table position of Ename>)); 10026 10027 -- Note that Obj'Address is recursively expanded into a call to 10028 -- Base_Address (Obj). 10029 10030 if Tagged_Type_Expansion then 10031 Prepend_To (Params, 10032 Make_Function_Call (Loc, 10033 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 10034 Parameter_Associations => New_List ( 10035 10036 Make_Explicit_Dereference (Loc, 10037 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 10038 Make_Attribute_Reference (Loc, 10039 Prefix => New_Copy_Tree (Concval), 10040 Attribute_Name => Name_Address))), 10041 10042 Make_Function_Call (Loc, 10043 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 10044 Parameter_Associations => New_List ( 10045 Unchecked_Convert_To (RTE (RE_Tag), Concval), 10046 Make_Integer_Literal (Loc, 10047 DT_Position (Entity (Ename)))))))); 10048 10049 -- VM targets 10050 10051 else 10052 Prepend_To (Params, 10053 Make_Function_Call (Loc, 10054 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 10055 Parameter_Associations => New_List ( 10056 10057 Make_Attribute_Reference (Loc, 10058 Prefix => Concval, 10059 Attribute_Name => Name_Tag), 10060 10061 Make_Function_Call (Loc, 10062 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 10063 10064 Parameter_Associations => New_List ( 10065 10066 -- Obj_Tag 10067 10068 Make_Attribute_Reference (Loc, 10069 Prefix => Concval, 10070 Attribute_Name => Name_Tag), 10071 10072 -- Tag_Typ 10073 10074 Make_Attribute_Reference (Loc, 10075 Prefix => New_Occurrence_Of (Etype (Concval), Loc), 10076 Attribute_Name => Name_Tag), 10077 10078 -- Position 10079 10080 Make_Integer_Literal (Loc, 10081 DT_Position (Entity (Ename)))))))); 10082 end if; 10083 10084 -- Specific actuals for protected to XXX requeue 10085 10086 if Is_Protected_Type (Old_Typ) then 10087 Prepend_To (Params, 10088 Make_Attribute_Reference (Loc, -- _object'Address 10089 Prefix => 10090 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10091 Attribute_Name => Name_Address)); 10092 10093 Prepend_To (Params, -- True 10094 New_Occurrence_Of (Standard_True, Loc)); 10095 10096 -- Specific actuals for task to XXX requeue 10097 10098 else 10099 pragma Assert (Is_Task_Type (Old_Typ)); 10100 10101 Prepend_To (Params, -- null 10102 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 10103 10104 Prepend_To (Params, -- False 10105 New_Occurrence_Of (Standard_False, Loc)); 10106 end if; 10107 10108 -- Add the object parameter 10109 10110 Prepend_To (Params, New_Copy_Tree (Concval)); 10111 10112 -- Generate: 10113 -- _Disp_Requeue (<Params>); 10114 10115 -- Find entity for Disp_Requeue operation, which belongs to 10116 -- the type and may not be directly visible. 10117 10118 declare 10119 Elmt : Elmt_Id; 10120 Op : Entity_Id; 10121 pragma Warnings (Off, Op); 10122 10123 begin 10124 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ))); 10125 while Present (Elmt) loop 10126 Op := Node (Elmt); 10127 exit when Chars (Op) = Name_uDisp_Requeue; 10128 Next_Elmt (Elmt); 10129 end loop; 10130 10131 return 10132 Make_Procedure_Call_Statement (Loc, 10133 Name => New_Occurrence_Of (Op, Loc), 10134 Parameter_Associations => Params); 10135 end; 10136 end Build_Dispatching_Requeue; 10137 10138 -------------------------------------- 10139 -- Build_Dispatching_Requeue_To_Any -- 10140 -------------------------------------- 10141 10142 function Build_Dispatching_Requeue_To_Any return Node_Id is 10143 Call_Ent : constant Entity_Id := Entity (Ename); 10144 Obj : constant Node_Id := Original_Node (Concval); 10145 Skip : constant Node_Id := Build_Skip_Statement (N); 10146 C : Entity_Id; 10147 Decls : List_Id; 10148 S : Entity_Id; 10149 Stmts : List_Id; 10150 10151 begin 10152 Decls := New_List; 10153 Stmts := New_List; 10154 10155 -- Dispatch table slot processing, generate: 10156 -- S : Integer; 10157 10158 S := Build_S (Loc, Decls); 10159 10160 -- Call kind processing, generate: 10161 -- C : Ada.Tags.Prim_Op_Kind; 10162 10163 C := Build_C (Loc, Decls); 10164 10165 -- Generate: 10166 -- S := Ada.Tags.Get_Offset_Index 10167 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent)); 10168 10169 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent)); 10170 10171 -- Generate: 10172 -- _Disp_Get_Prim_Op_Kind (Obj, S, C); 10173 10174 Append_To (Stmts, 10175 Make_Procedure_Call_Statement (Loc, 10176 Name => 10177 New_Occurrence_Of ( 10178 Find_Prim_Op (Etype (Etype (Obj)), 10179 Name_uDisp_Get_Prim_Op_Kind), 10180 Loc), 10181 Parameter_Associations => New_List ( 10182 New_Copy_Tree (Obj), 10183 New_Occurrence_Of (S, Loc), 10184 New_Occurrence_Of (C, Loc)))); 10185 10186 Append_To (Stmts, 10187 10188 -- if C = POK_Protected_Entry 10189 -- or else C = POK_Task_Entry 10190 -- then 10191 10192 Make_Implicit_If_Statement (N, 10193 Condition => 10194 Make_Op_Or (Loc, 10195 Left_Opnd => 10196 Make_Op_Eq (Loc, 10197 Left_Opnd => 10198 New_Occurrence_Of (C, Loc), 10199 Right_Opnd => 10200 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 10201 10202 Right_Opnd => 10203 Make_Op_Eq (Loc, 10204 Left_Opnd => 10205 New_Occurrence_Of (C, Loc), 10206 Right_Opnd => 10207 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 10208 10209 -- Dispatching requeue equivalent 10210 10211 Then_Statements => New_List ( 10212 Build_Dispatching_Requeue, 10213 Skip), 10214 10215 -- elsif C = POK_Protected_Procedure then 10216 10217 Elsif_Parts => New_List ( 10218 Make_Elsif_Part (Loc, 10219 Condition => 10220 Make_Op_Eq (Loc, 10221 Left_Opnd => 10222 New_Occurrence_Of (C, Loc), 10223 Right_Opnd => 10224 New_Occurrence_Of ( 10225 RTE (RE_POK_Protected_Procedure), Loc)), 10226 10227 -- Dispatching call equivalent 10228 10229 Then_Statements => New_List ( 10230 Build_Dispatching_Call_Equivalent))), 10231 10232 -- else 10233 -- raise Program_Error; 10234 -- end if; 10235 10236 Else_Statements => New_List ( 10237 Make_Raise_Program_Error (Loc, 10238 Reason => PE_Explicit_Raise)))); 10239 10240 -- Wrap everything into a block 10241 10242 return 10243 Make_Block_Statement (Loc, 10244 Declarations => Decls, 10245 Handled_Statement_Sequence => 10246 Make_Handled_Sequence_Of_Statements (Loc, 10247 Statements => Stmts)); 10248 end Build_Dispatching_Requeue_To_Any; 10249 10250 -------------------------- 10251 -- Build_Normal_Requeue -- 10252 -------------------------- 10253 10254 function Build_Normal_Requeue return Node_Id is 10255 Params : constant List_Id := New_List; 10256 Param : Node_Id; 10257 RT_Call : Node_Id; 10258 10259 begin 10260 -- Process the "with abort" parameter 10261 10262 Prepend_To (Params, 10263 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10264 10265 -- Add the index expression to the parameters. It is common among all 10266 -- four cases. 10267 10268 Prepend_To (Params, 10269 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ)); 10270 10271 if Is_Protected_Type (Old_Typ) then 10272 declare 10273 Self_Param : Node_Id; 10274 10275 begin 10276 Self_Param := 10277 Make_Attribute_Reference (Loc, 10278 Prefix => 10279 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10280 Attribute_Name => 10281 Name_Unchecked_Access); 10282 10283 -- Protected to protected requeue 10284 10285 if Is_Protected_Type (Conc_Typ) then 10286 RT_Call := 10287 New_Occurrence_Of ( 10288 RTE (RE_Requeue_Protected_Entry), Loc); 10289 10290 Param := 10291 Make_Attribute_Reference (Loc, 10292 Prefix => 10293 Concurrent_Ref (Concval), 10294 Attribute_Name => 10295 Name_Unchecked_Access); 10296 10297 -- Protected to task requeue 10298 10299 else pragma Assert (Is_Task_Type (Conc_Typ)); 10300 RT_Call := 10301 New_Occurrence_Of ( 10302 RTE (RE_Requeue_Protected_To_Task_Entry), Loc); 10303 10304 Param := Concurrent_Ref (Concval); 10305 end if; 10306 10307 Prepend_To (Params, Param); 10308 Prepend_To (Params, Self_Param); 10309 end; 10310 10311 else pragma Assert (Is_Task_Type (Old_Typ)); 10312 10313 -- Task to protected requeue 10314 10315 if Is_Protected_Type (Conc_Typ) then 10316 RT_Call := 10317 New_Occurrence_Of ( 10318 RTE (RE_Requeue_Task_To_Protected_Entry), Loc); 10319 10320 Param := 10321 Make_Attribute_Reference (Loc, 10322 Prefix => 10323 Concurrent_Ref (Concval), 10324 Attribute_Name => 10325 Name_Unchecked_Access); 10326 10327 -- Task to task requeue 10328 10329 else pragma Assert (Is_Task_Type (Conc_Typ)); 10330 RT_Call := 10331 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc); 10332 10333 Param := Concurrent_Ref (Concval); 10334 end if; 10335 10336 Prepend_To (Params, Param); 10337 end if; 10338 10339 return 10340 Make_Procedure_Call_Statement (Loc, 10341 Name => RT_Call, 10342 Parameter_Associations => Params); 10343 end Build_Normal_Requeue; 10344 10345 -------------------------- 10346 -- Build_Skip_Statement -- 10347 -------------------------- 10348 10349 function Build_Skip_Statement (Search : Node_Id) return Node_Id is 10350 Skip_Stmt : Node_Id; 10351 10352 begin 10353 -- Build a return statement to skip the rest of the entire body 10354 10355 if Is_Protected_Type (Old_Typ) then 10356 Skip_Stmt := Make_Simple_Return_Statement (Loc); 10357 10358 -- If the requeue is within a task, find the end label of the 10359 -- enclosing accept statement and create a goto statement to it. 10360 10361 else 10362 declare 10363 Acc : Node_Id; 10364 Label : Node_Id; 10365 10366 begin 10367 -- Climb the parent chain looking for the enclosing accept 10368 -- statement. 10369 10370 Acc := Parent (Search); 10371 while Present (Acc) 10372 and then Nkind (Acc) /= N_Accept_Statement 10373 loop 10374 Acc := Parent (Acc); 10375 end loop; 10376 10377 -- The last statement is the second label used for completing 10378 -- the rendezvous the usual way. The label we are looking for 10379 -- is right before it. 10380 10381 Label := 10382 Prev (Last (Statements (Handled_Statement_Sequence (Acc)))); 10383 10384 pragma Assert (Nkind (Label) = N_Label); 10385 10386 -- Generate a goto statement to skip the rest of the accept 10387 10388 Skip_Stmt := 10389 Make_Goto_Statement (Loc, 10390 Name => 10391 New_Occurrence_Of (Entity (Identifier (Label)), Loc)); 10392 end; 10393 end if; 10394 10395 Set_Analyzed (Skip_Stmt); 10396 10397 return Skip_Stmt; 10398 end Build_Skip_Statement; 10399 10400 -- Start of processing for Expand_N_Requeue_Statement 10401 10402 begin 10403 -- Extract the components of the entry call 10404 10405 Extract_Entry (N, Concval, Ename, Index); 10406 Conc_Typ := Etype (Concval); 10407 10408 -- If the prefix is an access to class-wide type, dereference to get 10409 -- object and entry type. 10410 10411 if Is_Access_Type (Conc_Typ) then 10412 Conc_Typ := Designated_Type (Conc_Typ); 10413 Rewrite (Concval, 10414 Make_Explicit_Dereference (Loc, Relocate_Node (Concval))); 10415 Analyze_And_Resolve (Concval, Conc_Typ); 10416 end if; 10417 10418 -- Examine the scope stack in order to find nearest enclosing protected 10419 -- or task type. This will constitute our invocation source. 10420 10421 Old_Typ := Current_Scope; 10422 while Present (Old_Typ) 10423 and then not Is_Protected_Type (Old_Typ) 10424 and then not Is_Task_Type (Old_Typ) 10425 loop 10426 Old_Typ := Scope (Old_Typ); 10427 end loop; 10428 10429 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form 10430 -- Concval.Ename where the type of Concval is class-wide concurrent 10431 -- interface. 10432 10433 if Ada_Version >= Ada_2012 10434 and then Present (Concval) 10435 and then Is_Class_Wide_Type (Conc_Typ) 10436 and then Is_Concurrent_Interface (Conc_Typ) 10437 then 10438 declare 10439 Has_Impl : Boolean := False; 10440 Impl_Kind : Name_Id := No_Name; 10441 10442 begin 10443 -- Check whether the Ename is flagged by pragma Implemented 10444 10445 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then 10446 Has_Impl := True; 10447 Impl_Kind := Implementation_Kind (Entity (Ename)); 10448 end if; 10449 10450 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10451 -- an entry. Create a call to predefined primitive _Disp_Requeue. 10452 10453 if Has_Impl and then Impl_Kind = Name_By_Entry then 10454 Rewrite (N, Build_Dispatching_Requeue); 10455 Analyze (N); 10456 Insert_After (N, Build_Skip_Statement (N)); 10457 10458 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10459 -- a protected procedure. In this case the requeue is transformed 10460 -- into a dispatching call. 10461 10462 elsif Has_Impl 10463 and then Impl_Kind = Name_By_Protected_Procedure 10464 then 10465 Rewrite (N, Build_Dispatching_Call_Equivalent); 10466 Analyze (N); 10467 10468 -- The procedure_or_entry_NAME's implementation kind is either 10469 -- By_Any, Optional, or pragma Implemented was not applied at all. 10470 -- In this case a runtime test determines whether Ename denotes an 10471 -- entry or a protected procedure and performs the appropriate 10472 -- call. 10473 10474 else 10475 Rewrite (N, Build_Dispatching_Requeue_To_Any); 10476 Analyze (N); 10477 end if; 10478 end; 10479 10480 -- Processing for regular (nondispatching) requeues 10481 10482 else 10483 Rewrite (N, Build_Normal_Requeue); 10484 Analyze (N); 10485 Insert_After (N, Build_Skip_Statement (N)); 10486 end if; 10487 end Expand_N_Requeue_Statement; 10488 10489 ------------------------------- 10490 -- Expand_N_Selective_Accept -- 10491 ------------------------------- 10492 10493 procedure Expand_N_Selective_Accept (N : Node_Id) is 10494 Loc : constant Source_Ptr := Sloc (N); 10495 Alts : constant List_Id := Select_Alternatives (N); 10496 10497 -- Note: in the below declarations a lot of new lists are allocated 10498 -- unconditionally which may well not end up being used. That's not 10499 -- a good idea since it wastes space gratuitously ??? 10500 10501 Accept_Case : List_Id; 10502 Accept_List : constant List_Id := New_List; 10503 10504 Alt : Node_Id; 10505 Alt_List : constant List_Id := New_List; 10506 Alt_Stats : List_Id; 10507 Ann : Entity_Id := Empty; 10508 10509 Check_Guard : Boolean := True; 10510 10511 Decls : constant List_Id := New_List; 10512 Stats : constant List_Id := New_List; 10513 Body_List : constant List_Id := New_List; 10514 Trailing_List : constant List_Id := New_List; 10515 10516 Choices : List_Id; 10517 Else_Present : Boolean := False; 10518 Terminate_Alt : Node_Id := Empty; 10519 Select_Mode : Node_Id; 10520 10521 Delay_Case : List_Id; 10522 Delay_Count : Integer := 0; 10523 Delay_Val : Entity_Id; 10524 Delay_Index : Entity_Id; 10525 Delay_Min : Entity_Id; 10526 Delay_Num : Pos := 1; 10527 Delay_Alt_List : List_Id := New_List; 10528 Delay_List : constant List_Id := New_List; 10529 D : Entity_Id; 10530 M : Entity_Id; 10531 10532 First_Delay : Boolean := True; 10533 Guard_Open : Entity_Id; 10534 10535 End_Lab : Node_Id; 10536 Index : Pos := 1; 10537 Lab : Node_Id; 10538 Num_Alts : Nat; 10539 Num_Accept : Nat := 0; 10540 Proc : Node_Id; 10541 Time_Type : Entity_Id; 10542 Select_Call : Node_Id; 10543 10544 Qnam : constant Entity_Id := 10545 Make_Defining_Identifier (Loc, New_External_Name ('S', 0)); 10546 10547 Xnam : constant Entity_Id := 10548 Make_Defining_Identifier (Loc, New_External_Name ('J', 1)); 10549 10550 ----------------------- 10551 -- Local subprograms -- 10552 ----------------------- 10553 10554 function Accept_Or_Raise return List_Id; 10555 -- For the rare case where delay alternatives all have guards, and 10556 -- all of them are closed, it is still possible that there were open 10557 -- accept alternatives with no callers. We must reexamine the 10558 -- Accept_List, and execute a selective wait with no else if some 10559 -- accept is open. If none, we raise program_error. 10560 10561 procedure Add_Accept (Alt : Node_Id); 10562 -- Process a single accept statement in a select alternative. Build 10563 -- procedure for body of accept, and add entry to dispatch table with 10564 -- expression for guard, in preparation for call to run time select. 10565 10566 function Make_And_Declare_Label (Num : Int) return Node_Id; 10567 -- Manufacture a label using Num as a serial number and declare it. 10568 -- The declaration is appended to Decls. The label marks the trailing 10569 -- statements of an accept or delay alternative. 10570 10571 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; 10572 -- Build call to Selective_Wait runtime routine 10573 10574 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); 10575 -- Add code to compare value of delay with previous values, and 10576 -- generate case entry for trailing statements. 10577 10578 procedure Process_Accept_Alternative 10579 (Alt : Node_Id; 10580 Index : Int; 10581 Proc : Node_Id); 10582 -- Add code to call corresponding procedure, and branch to 10583 -- trailing statements, if any. 10584 10585 --------------------- 10586 -- Accept_Or_Raise -- 10587 --------------------- 10588 10589 function Accept_Or_Raise return List_Id is 10590 Cond : Node_Id; 10591 Stats : List_Id; 10592 J : constant Entity_Id := Make_Temporary (Loc, 'J'); 10593 10594 begin 10595 -- We generate the following: 10596 10597 -- for J in q'range loop 10598 -- if q(J).S /=null_task_entry then 10599 -- selective_wait (simple_mode,...); 10600 -- done := True; 10601 -- exit; 10602 -- end if; 10603 -- end loop; 10604 -- 10605 -- if no rendez_vous then 10606 -- raise program_error; 10607 -- end if; 10608 10609 -- Note that the code needs to know that the selector name 10610 -- in an Accept_Alternative is named S. 10611 10612 Cond := Make_Op_Ne (Loc, 10613 Left_Opnd => 10614 Make_Selected_Component (Loc, 10615 Prefix => 10616 Make_Indexed_Component (Loc, 10617 Prefix => New_Occurrence_Of (Qnam, Loc), 10618 Expressions => New_List (New_Occurrence_Of (J, Loc))), 10619 Selector_Name => Make_Identifier (Loc, Name_S)), 10620 Right_Opnd => 10621 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc)); 10622 10623 Stats := New_List ( 10624 Make_Implicit_Loop_Statement (N, 10625 Iteration_Scheme => 10626 Make_Iteration_Scheme (Loc, 10627 Loop_Parameter_Specification => 10628 Make_Loop_Parameter_Specification (Loc, 10629 Defining_Identifier => J, 10630 Discrete_Subtype_Definition => 10631 Make_Attribute_Reference (Loc, 10632 Prefix => New_Occurrence_Of (Qnam, Loc), 10633 Attribute_Name => Name_Range, 10634 Expressions => New_List ( 10635 Make_Integer_Literal (Loc, 1))))), 10636 10637 Statements => New_List ( 10638 Make_Implicit_If_Statement (N, 10639 Condition => Cond, 10640 Then_Statements => New_List ( 10641 Make_Select_Call ( 10642 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)), 10643 Make_Exit_Statement (Loc)))))); 10644 10645 Append_To (Stats, 10646 Make_Raise_Program_Error (Loc, 10647 Condition => Make_Op_Eq (Loc, 10648 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 10649 Right_Opnd => 10650 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 10651 Reason => PE_All_Guards_Closed)); 10652 10653 return Stats; 10654 end Accept_Or_Raise; 10655 10656 ---------------- 10657 -- Add_Accept -- 10658 ---------------- 10659 10660 procedure Add_Accept (Alt : Node_Id) is 10661 Acc_Stm : constant Node_Id := Accept_Statement (Alt); 10662 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm); 10663 Eloc : constant Source_Ptr := Sloc (Ename); 10664 Eent : constant Entity_Id := Entity (Ename); 10665 Index : constant Node_Id := Entry_Index (Acc_Stm); 10666 10667 Call : Node_Id; 10668 Expr : Node_Id; 10669 Null_Body : Node_Id; 10670 PB_Ent : Entity_Id; 10671 Proc_Body : Node_Id; 10672 10673 -- Start of processing for Add_Accept 10674 10675 begin 10676 if No (Ann) then 10677 Ann := Node (Last_Elmt (Accept_Address (Eent))); 10678 end if; 10679 10680 if Present (Condition (Alt)) then 10681 Expr := 10682 Make_If_Expression (Eloc, New_List ( 10683 Condition (Alt), 10684 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)), 10685 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc))); 10686 else 10687 Expr := Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)); 10688 end if; 10689 10690 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then 10691 Null_Body := New_Occurrence_Of (Standard_False, Eloc); 10692 10693 -- Always add call to Abort_Undefer when generating code, since 10694 -- this is what the runtime expects (abort deferred in 10695 -- Selective_Wait). In CodePeer mode this only confuses the 10696 -- analysis with unknown calls, so don't do it. 10697 10698 if not CodePeer_Mode then 10699 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 10700 Insert_Before 10701 (First (Statements (Handled_Statement_Sequence 10702 (Accept_Statement (Alt)))), 10703 Call); 10704 Analyze (Call); 10705 end if; 10706 10707 PB_Ent := 10708 Make_Defining_Identifier (Eloc, 10709 New_External_Name (Chars (Ename), 'A', Num_Accept)); 10710 10711 -- Link the acceptor to the original receiving entry 10712 10713 Set_Ekind (PB_Ent, E_Procedure); 10714 Set_Receiving_Entry (PB_Ent, Eent); 10715 10716 if Comes_From_Source (Alt) then 10717 Set_Debug_Info_Needed (PB_Ent); 10718 end if; 10719 10720 Proc_Body := 10721 Make_Subprogram_Body (Eloc, 10722 Specification => 10723 Make_Procedure_Specification (Eloc, 10724 Defining_Unit_Name => PB_Ent), 10725 Declarations => Declarations (Acc_Stm), 10726 Handled_Statement_Sequence => 10727 Build_Accept_Body (Accept_Statement (Alt))); 10728 10729 Reset_Scopes_To (Proc_Body, PB_Ent); 10730 10731 -- During the analysis of the body of the accept statement, any 10732 -- zero cost exception handler records were collected in the 10733 -- Accept_Handler_Records field of the N_Accept_Alternative node. 10734 -- This is where we move them to where they belong, namely the 10735 -- newly created procedure. 10736 10737 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); 10738 Append (Proc_Body, Body_List); 10739 10740 else 10741 Null_Body := New_Occurrence_Of (Standard_True, Eloc); 10742 10743 -- if accept statement has declarations, insert above, given that 10744 -- we are not creating a body for the accept. 10745 10746 if Present (Declarations (Acc_Stm)) then 10747 Insert_Actions (N, Declarations (Acc_Stm)); 10748 end if; 10749 end if; 10750 10751 Append_To (Accept_List, 10752 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr))); 10753 10754 Num_Accept := Num_Accept + 1; 10755 end Add_Accept; 10756 10757 ---------------------------- 10758 -- Make_And_Declare_Label -- 10759 ---------------------------- 10760 10761 function Make_And_Declare_Label (Num : Int) return Node_Id is 10762 Lab_Id : Node_Id; 10763 10764 begin 10765 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num)); 10766 Lab := 10767 Make_Label (Loc, Lab_Id); 10768 10769 Append_To (Decls, 10770 Make_Implicit_Label_Declaration (Loc, 10771 Defining_Identifier => 10772 Make_Defining_Identifier (Loc, Chars (Lab_Id)), 10773 Label_Construct => Lab)); 10774 10775 return Lab; 10776 end Make_And_Declare_Label; 10777 10778 ---------------------- 10779 -- Make_Select_Call -- 10780 ---------------------- 10781 10782 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is 10783 Params : constant List_Id := New_List; 10784 10785 begin 10786 Append_To (Params, 10787 Make_Attribute_Reference (Loc, 10788 Prefix => New_Occurrence_Of (Qnam, Loc), 10789 Attribute_Name => Name_Unchecked_Access)); 10790 Append_To (Params, Select_Mode); 10791 Append_To (Params, New_Occurrence_Of (Ann, Loc)); 10792 Append_To (Params, New_Occurrence_Of (Xnam, Loc)); 10793 10794 return 10795 Make_Procedure_Call_Statement (Loc, 10796 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc), 10797 Parameter_Associations => Params); 10798 end Make_Select_Call; 10799 10800 -------------------------------- 10801 -- Process_Accept_Alternative -- 10802 -------------------------------- 10803 10804 procedure Process_Accept_Alternative 10805 (Alt : Node_Id; 10806 Index : Int; 10807 Proc : Node_Id) 10808 is 10809 Astmt : constant Node_Id := Accept_Statement (Alt); 10810 Alt_Stats : List_Id; 10811 10812 begin 10813 Adjust_Condition (Condition (Alt)); 10814 10815 -- Accept with body 10816 10817 if Present (Handled_Statement_Sequence (Astmt)) then 10818 Alt_Stats := 10819 New_List ( 10820 Make_Procedure_Call_Statement (Sloc (Proc), 10821 Name => 10822 New_Occurrence_Of 10823 (Defining_Unit_Name (Specification (Proc)), 10824 Sloc (Proc)))); 10825 10826 -- Accept with no body (followed by trailing statements) 10827 10828 else 10829 Alt_Stats := Empty_List; 10830 end if; 10831 10832 Ensure_Statement_Present (Sloc (Astmt), Alt); 10833 10834 -- After the call, if any, branch to trailing statements, if any. 10835 -- We create a label for each, as well as the corresponding label 10836 -- declaration. 10837 10838 if not Is_Empty_List (Statements (Alt)) then 10839 Lab := Make_And_Declare_Label (Index); 10840 Append (Lab, Trailing_List); 10841 Append_List (Statements (Alt), Trailing_List); 10842 Append_To (Trailing_List, 10843 Make_Goto_Statement (Loc, 10844 Name => New_Copy (Identifier (End_Lab)))); 10845 10846 else 10847 Lab := End_Lab; 10848 end if; 10849 10850 Append_To (Alt_Stats, 10851 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab)))); 10852 10853 Append_To (Alt_List, 10854 Make_Case_Statement_Alternative (Loc, 10855 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)), 10856 Statements => Alt_Stats)); 10857 end Process_Accept_Alternative; 10858 10859 ------------------------------- 10860 -- Process_Delay_Alternative -- 10861 ------------------------------- 10862 10863 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is 10864 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt)); 10865 Cond : Node_Id; 10866 Delay_Alt : List_Id; 10867 10868 begin 10869 -- Deal with C/Fortran boolean as delay condition 10870 10871 Adjust_Condition (Condition (Alt)); 10872 10873 -- Determine the smallest specified delay 10874 10875 -- for each delay alternative generate: 10876 10877 -- if guard-expression then 10878 -- Delay_Val := delay-expression; 10879 -- Guard_Open := True; 10880 -- if Delay_Val < Delay_Min then 10881 -- Delay_Min := Delay_Val; 10882 -- Delay_Index := Index; 10883 -- end if; 10884 -- end if; 10885 10886 -- The enclosing if-statement is omitted if there is no guard 10887 10888 if Delay_Count = 1 or else First_Delay then 10889 First_Delay := False; 10890 10891 Delay_Alt := New_List ( 10892 Make_Assignment_Statement (Loc, 10893 Name => New_Occurrence_Of (Delay_Min, Loc), 10894 Expression => Expression (Delay_Statement (Alt)))); 10895 10896 if Delay_Count > 1 then 10897 Append_To (Delay_Alt, 10898 Make_Assignment_Statement (Loc, 10899 Name => New_Occurrence_Of (Delay_Index, Loc), 10900 Expression => Make_Integer_Literal (Loc, Index))); 10901 end if; 10902 10903 else 10904 Delay_Alt := New_List ( 10905 Make_Assignment_Statement (Loc, 10906 Name => New_Occurrence_Of (Delay_Val, Loc), 10907 Expression => Expression (Delay_Statement (Alt)))); 10908 10909 if Time_Type = Standard_Duration then 10910 Cond := 10911 Make_Op_Lt (Loc, 10912 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc), 10913 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc)); 10914 10915 else 10916 -- The scope of the time type must define a comparison 10917 -- operator. The scope itself may not be visible, so we 10918 -- construct a node with entity information to insure that 10919 -- semantic analysis can find the proper operator. 10920 10921 Cond := 10922 Make_Function_Call (Loc, 10923 Name => Make_Selected_Component (Loc, 10924 Prefix => 10925 New_Occurrence_Of (Scope (Time_Type), Loc), 10926 Selector_Name => 10927 Make_Operator_Symbol (Loc, 10928 Chars => Name_Op_Lt, 10929 Strval => No_String)), 10930 Parameter_Associations => 10931 New_List ( 10932 New_Occurrence_Of (Delay_Val, Loc), 10933 New_Occurrence_Of (Delay_Min, Loc))); 10934 10935 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type)); 10936 end if; 10937 10938 Append_To (Delay_Alt, 10939 Make_Implicit_If_Statement (N, 10940 Condition => Cond, 10941 Then_Statements => New_List ( 10942 Make_Assignment_Statement (Loc, 10943 Name => New_Occurrence_Of (Delay_Min, Loc), 10944 Expression => New_Occurrence_Of (Delay_Val, Loc)), 10945 10946 Make_Assignment_Statement (Loc, 10947 Name => New_Occurrence_Of (Delay_Index, Loc), 10948 Expression => Make_Integer_Literal (Loc, Index))))); 10949 end if; 10950 10951 if Check_Guard then 10952 Append_To (Delay_Alt, 10953 Make_Assignment_Statement (Loc, 10954 Name => New_Occurrence_Of (Guard_Open, Loc), 10955 Expression => New_Occurrence_Of (Standard_True, Loc))); 10956 end if; 10957 10958 if Present (Condition (Alt)) then 10959 Delay_Alt := New_List ( 10960 Make_Implicit_If_Statement (N, 10961 Condition => Condition (Alt), 10962 Then_Statements => Delay_Alt)); 10963 end if; 10964 10965 Append_List (Delay_Alt, Delay_List); 10966 10967 Ensure_Statement_Present (Dloc, Alt); 10968 10969 -- If the delay alternative has a statement part, add choice to the 10970 -- case statements for delays. 10971 10972 if not Is_Empty_List (Statements (Alt)) then 10973 10974 if Delay_Count = 1 then 10975 Append_List (Statements (Alt), Delay_Alt_List); 10976 10977 else 10978 Append_To (Delay_Alt_List, 10979 Make_Case_Statement_Alternative (Loc, 10980 Discrete_Choices => New_List ( 10981 Make_Integer_Literal (Loc, Index)), 10982 Statements => Statements (Alt))); 10983 end if; 10984 10985 elsif Delay_Count = 1 then 10986 10987 -- If the single delay has no trailing statements, add a branch 10988 -- to the exit label to the selective wait. 10989 10990 Delay_Alt_List := New_List ( 10991 Make_Goto_Statement (Loc, 10992 Name => New_Copy (Identifier (End_Lab)))); 10993 10994 end if; 10995 end Process_Delay_Alternative; 10996 10997 -- Start of processing for Expand_N_Selective_Accept 10998 10999 begin 11000 Process_Statements_For_Controlled_Objects (N); 11001 11002 -- First insert some declarations before the select. The first is: 11003 11004 -- Ann : Address 11005 11006 -- This variable holds the parameters passed to the accept body. This 11007 -- declaration has already been inserted by the time we get here by 11008 -- a call to Expand_Accept_Declarations made from the semantics when 11009 -- processing the first accept statement contained in the select. We 11010 -- can find this entity as Accept_Address (E), where E is any of the 11011 -- entries references by contained accept statements. 11012 11013 -- The first step is to scan the list of Selective_Accept_Statements 11014 -- to find this entity, and also count the number of accepts, and 11015 -- determine if terminated, delay or else is present: 11016 11017 Num_Alts := 0; 11018 11019 Alt := First (Alts); 11020 while Present (Alt) loop 11021 Process_Statements_For_Controlled_Objects (Alt); 11022 11023 if Nkind (Alt) = N_Accept_Alternative then 11024 Add_Accept (Alt); 11025 11026 elsif Nkind (Alt) = N_Delay_Alternative then 11027 Delay_Count := Delay_Count + 1; 11028 11029 -- If the delays are relative delays, the delay expressions have 11030 -- type Standard_Duration. Otherwise they must have some time type 11031 -- recognized by GNAT. 11032 11033 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then 11034 Time_Type := Standard_Duration; 11035 else 11036 Time_Type := Etype (Expression (Delay_Statement (Alt))); 11037 11038 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) 11039 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time) 11040 then 11041 null; 11042 else 11043 Error_Msg_NE ( 11044 "& is not a time type (RM 9.6(6))", 11045 Expression (Delay_Statement (Alt)), Time_Type); 11046 Time_Type := Standard_Duration; 11047 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type); 11048 end if; 11049 end if; 11050 11051 if No (Condition (Alt)) then 11052 11053 -- This guard will always be open 11054 11055 Check_Guard := False; 11056 end if; 11057 11058 elsif Nkind (Alt) = N_Terminate_Alternative then 11059 Adjust_Condition (Condition (Alt)); 11060 Terminate_Alt := Alt; 11061 end if; 11062 11063 Num_Alts := Num_Alts + 1; 11064 Next (Alt); 11065 end loop; 11066 11067 Else_Present := Present (Else_Statements (N)); 11068 11069 -- At the same time (see procedure Add_Accept) we build the accept list: 11070 11071 -- Qnn : Accept_List (1 .. num-select) := ( 11072 -- (null-body, entry-index), 11073 -- (null-body, entry-index), 11074 -- .. 11075 -- (null_body, entry-index)); 11076 11077 -- In the above declaration, null-body is True if the corresponding 11078 -- accept has no body, and false otherwise. The entry is either the 11079 -- entry index expression if there is no guard, or if a guard is 11080 -- present, then an if expression of the form: 11081 11082 -- (if guard then entry-index else Null_Task_Entry) 11083 11084 -- If a guard is statically known to be false, the entry can simply 11085 -- be omitted from the accept list. 11086 11087 Append_To (Decls, 11088 Make_Object_Declaration (Loc, 11089 Defining_Identifier => Qnam, 11090 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc), 11091 Aliased_Present => True, 11092 Expression => 11093 Make_Qualified_Expression (Loc, 11094 Subtype_Mark => 11095 New_Occurrence_Of (RTE (RE_Accept_List), Loc), 11096 Expression => 11097 Make_Aggregate (Loc, Expressions => Accept_List)))); 11098 11099 -- Then we declare the variable that holds the index for the accept 11100 -- that will be selected for service: 11101 11102 -- Xnn : Select_Index; 11103 11104 Append_To (Decls, 11105 Make_Object_Declaration (Loc, 11106 Defining_Identifier => Xnam, 11107 Object_Definition => 11108 New_Occurrence_Of (RTE (RE_Select_Index), Loc), 11109 Expression => 11110 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc))); 11111 11112 -- After this follow procedure declarations for each accept body 11113 11114 -- procedure Pnn is 11115 -- begin 11116 -- ... 11117 -- end; 11118 11119 -- where the ... are statements from the corresponding procedure body. 11120 -- No parameters are involved, since the parameters are passed via Ann 11121 -- and the parameter references have already been expanded to be direct 11122 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, 11123 -- any embedded tasking statements (which would normally be illegal in 11124 -- procedures), have been converted to calls to the tasking runtime so 11125 -- there is no problem in putting them into procedures. 11126 11127 -- The original accept statement has been expanded into a block in 11128 -- the same fashion as for simple accepts (see Build_Accept_Body). 11129 11130 -- Note: we don't really need to build these procedures for the case 11131 -- where no delay statement is present, but it is just as easy to 11132 -- build them unconditionally, and not significantly inefficient, 11133 -- since if they are short they will be inlined anyway. 11134 11135 -- The procedure declarations have been assembled in Body_List 11136 11137 -- If delays are present, we must compute the required delay. 11138 -- We first generate the declarations: 11139 11140 -- Delay_Index : Boolean := 0; 11141 -- Delay_Min : Some_Time_Type.Time; 11142 -- Delay_Val : Some_Time_Type.Time; 11143 11144 -- Delay_Index will be set to the index of the minimum delay, i.e. the 11145 -- active delay that is actually chosen as the basis for the possible 11146 -- delay if an immediate rendez-vous is not possible. 11147 11148 -- In the most common case there is a single delay statement, and this 11149 -- is handled specially. 11150 11151 if Delay_Count > 0 then 11152 11153 -- Generate the required declarations 11154 11155 Delay_Val := 11156 Make_Defining_Identifier (Loc, New_External_Name ('D', 1)); 11157 Delay_Index := 11158 Make_Defining_Identifier (Loc, New_External_Name ('D', 2)); 11159 Delay_Min := 11160 Make_Defining_Identifier (Loc, New_External_Name ('D', 3)); 11161 11162 Append_To (Decls, 11163 Make_Object_Declaration (Loc, 11164 Defining_Identifier => Delay_Val, 11165 Object_Definition => New_Occurrence_Of (Time_Type, Loc))); 11166 11167 Append_To (Decls, 11168 Make_Object_Declaration (Loc, 11169 Defining_Identifier => Delay_Index, 11170 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 11171 Expression => Make_Integer_Literal (Loc, 0))); 11172 11173 Append_To (Decls, 11174 Make_Object_Declaration (Loc, 11175 Defining_Identifier => Delay_Min, 11176 Object_Definition => New_Occurrence_Of (Time_Type, Loc), 11177 Expression => 11178 Unchecked_Convert_To (Time_Type, 11179 Make_Attribute_Reference (Loc, 11180 Prefix => 11181 New_Occurrence_Of (Underlying_Type (Time_Type), Loc), 11182 Attribute_Name => Name_Last)))); 11183 11184 -- Create Duration and Delay_Mode objects used for passing a delay 11185 -- value to RTS 11186 11187 D := Make_Temporary (Loc, 'D'); 11188 M := Make_Temporary (Loc, 'M'); 11189 11190 declare 11191 Discr : Entity_Id; 11192 11193 begin 11194 -- Note that these values are defined in s-osprim.ads and must 11195 -- be kept in sync: 11196 -- 11197 -- Relative : constant := 0; 11198 -- Absolute_Calendar : constant := 1; 11199 -- Absolute_RT : constant := 2; 11200 11201 if Time_Type = Standard_Duration then 11202 Discr := Make_Integer_Literal (Loc, 0); 11203 11204 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11205 Discr := Make_Integer_Literal (Loc, 1); 11206 11207 else 11208 pragma Assert 11209 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11210 Discr := Make_Integer_Literal (Loc, 2); 11211 end if; 11212 11213 Append_To (Decls, 11214 Make_Object_Declaration (Loc, 11215 Defining_Identifier => D, 11216 Object_Definition => 11217 New_Occurrence_Of (Standard_Duration, Loc))); 11218 11219 Append_To (Decls, 11220 Make_Object_Declaration (Loc, 11221 Defining_Identifier => M, 11222 Object_Definition => 11223 New_Occurrence_Of (Standard_Integer, Loc), 11224 Expression => Discr)); 11225 end; 11226 11227 if Check_Guard then 11228 Guard_Open := 11229 Make_Defining_Identifier (Loc, New_External_Name ('G', 1)); 11230 11231 Append_To (Decls, 11232 Make_Object_Declaration (Loc, 11233 Defining_Identifier => Guard_Open, 11234 Object_Definition => 11235 New_Occurrence_Of (Standard_Boolean, Loc), 11236 Expression => 11237 New_Occurrence_Of (Standard_False, Loc))); 11238 end if; 11239 11240 -- Delay_Count is zero, don't need M and D set (suppress warning) 11241 11242 else 11243 M := Empty; 11244 D := Empty; 11245 end if; 11246 11247 if Present (Terminate_Alt) then 11248 11249 -- If the terminate alternative guard is False, use 11250 -- Simple_Mode; otherwise use Terminate_Mode. 11251 11252 if Present (Condition (Terminate_Alt)) then 11253 Select_Mode := Make_If_Expression (Loc, 11254 New_List (Condition (Terminate_Alt), 11255 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc), 11256 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc))); 11257 else 11258 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc); 11259 end if; 11260 11261 elsif Else_Present or Delay_Count > 0 then 11262 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc); 11263 11264 else 11265 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc); 11266 end if; 11267 11268 Select_Call := Make_Select_Call (Select_Mode); 11269 Append (Select_Call, Stats); 11270 11271 -- Now generate code to act on the result. There is an entry 11272 -- in this case for each accept statement with a non-null body, 11273 -- followed by a branch to the statements that follow the Accept. 11274 -- In the absence of delay alternatives, we generate: 11275 11276 -- case X is 11277 -- when No_Rendezvous => -- omitted if simple mode 11278 -- goto Lab0; 11279 11280 -- when 1 => 11281 -- P1n; 11282 -- goto Lab1; 11283 11284 -- when 2 => 11285 -- P2n; 11286 -- goto Lab2; 11287 11288 -- when others => 11289 -- goto Exit; 11290 -- end case; 11291 -- 11292 -- Lab0: Else_Statements; 11293 -- goto exit; 11294 11295 -- Lab1: Trailing_Statements1; 11296 -- goto Exit; 11297 -- 11298 -- Lab2: Trailing_Statements2; 11299 -- goto Exit; 11300 -- ... 11301 -- Exit: 11302 11303 -- Generate label for common exit 11304 11305 End_Lab := Make_And_Declare_Label (Num_Alts + 1); 11306 11307 -- First entry is the default case, when no rendezvous is possible 11308 11309 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)); 11310 11311 if Else_Present then 11312 11313 -- If no rendezvous is possible, the else part is executed 11314 11315 Lab := Make_And_Declare_Label (0); 11316 Alt_Stats := New_List ( 11317 Make_Goto_Statement (Loc, 11318 Name => New_Copy (Identifier (Lab)))); 11319 11320 Append (Lab, Trailing_List); 11321 Append_List (Else_Statements (N), Trailing_List); 11322 Append_To (Trailing_List, 11323 Make_Goto_Statement (Loc, 11324 Name => New_Copy (Identifier (End_Lab)))); 11325 else 11326 Alt_Stats := New_List ( 11327 Make_Goto_Statement (Loc, 11328 Name => New_Copy (Identifier (End_Lab)))); 11329 end if; 11330 11331 Append_To (Alt_List, 11332 Make_Case_Statement_Alternative (Loc, 11333 Discrete_Choices => Choices, 11334 Statements => Alt_Stats)); 11335 11336 -- We make use of the fact that Accept_Index is an integer type, and 11337 -- generate successive literals for entries for each accept. Only those 11338 -- for which there is a body or trailing statements get a case entry. 11339 11340 Alt := First (Select_Alternatives (N)); 11341 Proc := First (Body_List); 11342 while Present (Alt) loop 11343 11344 if Nkind (Alt) = N_Accept_Alternative then 11345 Process_Accept_Alternative (Alt, Index, Proc); 11346 Index := Index + 1; 11347 11348 if Present 11349 (Handled_Statement_Sequence (Accept_Statement (Alt))) 11350 then 11351 Next (Proc); 11352 end if; 11353 11354 elsif Nkind (Alt) = N_Delay_Alternative then 11355 Process_Delay_Alternative (Alt, Delay_Num); 11356 Delay_Num := Delay_Num + 1; 11357 end if; 11358 11359 Next (Alt); 11360 end loop; 11361 11362 -- An others choice is always added to the main case, as well 11363 -- as the delay case (to satisfy the compiler). 11364 11365 Append_To (Alt_List, 11366 Make_Case_Statement_Alternative (Loc, 11367 Discrete_Choices => 11368 New_List (Make_Others_Choice (Loc)), 11369 Statements => 11370 New_List (Make_Goto_Statement (Loc, 11371 Name => New_Copy (Identifier (End_Lab)))))); 11372 11373 Accept_Case := New_List ( 11374 Make_Case_Statement (Loc, 11375 Expression => New_Occurrence_Of (Xnam, Loc), 11376 Alternatives => Alt_List)); 11377 11378 Append_List (Trailing_List, Accept_Case); 11379 Append_List (Body_List, Decls); 11380 11381 -- Construct case statement for trailing statements of delay 11382 -- alternatives, if there are several of them. 11383 11384 if Delay_Count > 1 then 11385 Append_To (Delay_Alt_List, 11386 Make_Case_Statement_Alternative (Loc, 11387 Discrete_Choices => 11388 New_List (Make_Others_Choice (Loc)), 11389 Statements => 11390 New_List (Make_Null_Statement (Loc)))); 11391 11392 Delay_Case := New_List ( 11393 Make_Case_Statement (Loc, 11394 Expression => New_Occurrence_Of (Delay_Index, Loc), 11395 Alternatives => Delay_Alt_List)); 11396 else 11397 Delay_Case := Delay_Alt_List; 11398 end if; 11399 11400 -- If there are no delay alternatives, we append the case statement 11401 -- to the statement list. 11402 11403 if Delay_Count = 0 then 11404 Append_List (Accept_Case, Stats); 11405 11406 -- Delay alternatives present 11407 11408 else 11409 -- If delay alternatives are present we generate: 11410 11411 -- find minimum delay. 11412 -- DX := minimum delay; 11413 -- M := <delay mode>; 11414 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P, 11415 -- DX, MX, X); 11416 -- 11417 -- if X = No_Rendezvous then 11418 -- case statement for delay statements. 11419 -- else 11420 -- case statement for accept alternatives. 11421 -- end if; 11422 11423 declare 11424 Cases : Node_Id; 11425 Stmt : Node_Id; 11426 Parms : List_Id; 11427 Parm : Node_Id; 11428 Conv : Node_Id; 11429 11430 begin 11431 -- The type of the delay expression is known to be legal 11432 11433 if Time_Type = Standard_Duration then 11434 Conv := New_Occurrence_Of (Delay_Min, Loc); 11435 11436 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11437 Conv := Make_Function_Call (Loc, 11438 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 11439 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11440 11441 else 11442 pragma Assert 11443 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11444 11445 Conv := Make_Function_Call (Loc, 11446 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 11447 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11448 end if; 11449 11450 Stmt := Make_Assignment_Statement (Loc, 11451 Name => New_Occurrence_Of (D, Loc), 11452 Expression => Conv); 11453 11454 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) 11455 11456 Parms := Parameter_Associations (Select_Call); 11457 11458 Parm := First (Parms); 11459 while Present (Parm) and then Parm /= Select_Mode loop 11460 Next (Parm); 11461 end loop; 11462 11463 pragma Assert (Present (Parm)); 11464 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc)); 11465 Analyze (Parm); 11466 11467 -- Prepare two new parameters of Duration and Delay_Mode type 11468 -- which represent the value and the mode of the minimum delay. 11469 11470 Next (Parm); 11471 Insert_After (Parm, New_Occurrence_Of (M, Loc)); 11472 Insert_After (Parm, New_Occurrence_Of (D, Loc)); 11473 11474 -- Create a call to RTS 11475 11476 Rewrite (Select_Call, 11477 Make_Procedure_Call_Statement (Loc, 11478 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc), 11479 Parameter_Associations => Parms)); 11480 11481 -- This new call should follow the calculation of the minimum 11482 -- delay. 11483 11484 Insert_List_Before (Select_Call, Delay_List); 11485 11486 if Check_Guard then 11487 Stmt := 11488 Make_Implicit_If_Statement (N, 11489 Condition => New_Occurrence_Of (Guard_Open, Loc), 11490 Then_Statements => New_List ( 11491 New_Copy_Tree (Stmt), 11492 New_Copy_Tree (Select_Call)), 11493 Else_Statements => Accept_Or_Raise); 11494 Rewrite (Select_Call, Stmt); 11495 else 11496 Insert_Before (Select_Call, Stmt); 11497 end if; 11498 11499 Cases := 11500 Make_Implicit_If_Statement (N, 11501 Condition => Make_Op_Eq (Loc, 11502 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 11503 Right_Opnd => 11504 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 11505 11506 Then_Statements => Delay_Case, 11507 Else_Statements => Accept_Case); 11508 11509 Append (Cases, Stats); 11510 end; 11511 end if; 11512 11513 Append (End_Lab, Stats); 11514 11515 -- Replace accept statement with appropriate block 11516 11517 Rewrite (N, 11518 Make_Block_Statement (Loc, 11519 Declarations => Decls, 11520 Handled_Statement_Sequence => 11521 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats))); 11522 Analyze (N); 11523 11524 -- Note: have to worry more about abort deferral in above code ??? 11525 11526 -- Final step is to unstack the Accept_Address entries for all accept 11527 -- statements appearing in accept alternatives in the select statement 11528 11529 Alt := First (Alts); 11530 while Present (Alt) loop 11531 if Nkind (Alt) = N_Accept_Alternative then 11532 Remove_Last_Elmt (Accept_Address 11533 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))); 11534 end if; 11535 11536 Next (Alt); 11537 end loop; 11538 end Expand_N_Selective_Accept; 11539 11540 ------------------------------------------- 11541 -- Expand_N_Single_Protected_Declaration -- 11542 ------------------------------------------- 11543 11544 -- A single protected declaration should never be present after semantic 11545 -- analysis because it is transformed into a protected type declaration 11546 -- and an accompanying anonymous object. This routine ensures that the 11547 -- transformation takes place. 11548 11549 procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is 11550 begin 11551 raise Program_Error; 11552 end Expand_N_Single_Protected_Declaration; 11553 11554 -------------------------------------- 11555 -- Expand_N_Single_Task_Declaration -- 11556 -------------------------------------- 11557 11558 -- A single task declaration should never be present after semantic 11559 -- analysis because it is transformed into a task type declaration and 11560 -- an accompanying anonymous object. This routine ensures that the 11561 -- transformation takes place. 11562 11563 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is 11564 begin 11565 raise Program_Error; 11566 end Expand_N_Single_Task_Declaration; 11567 11568 ------------------------ 11569 -- Expand_N_Task_Body -- 11570 ------------------------ 11571 11572 -- Given a task body 11573 11574 -- task body tname is 11575 -- <declarations> 11576 -- begin 11577 -- <statements> 11578 -- end x; 11579 11580 -- This expansion routine converts it into a procedure and sets the 11581 -- elaboration flag for the procedure to true, to represent the fact 11582 -- that the task body is now elaborated: 11583 11584 -- procedure tnameB (_Task : access tnameV) is 11585 -- discriminal : dtype renames _Task.discriminant; 11586 11587 -- procedure _clean is 11588 -- begin 11589 -- Abort_Defer.all; 11590 -- Complete_Task; 11591 -- Abort_Undefer.all; 11592 -- return; 11593 -- end _clean; 11594 11595 -- begin 11596 -- Abort_Undefer.all; 11597 -- <declarations> 11598 -- System.Task_Stages.Complete_Activation; 11599 -- <statements> 11600 -- at end 11601 -- _clean; 11602 -- end tnameB; 11603 11604 -- tnameE := True; 11605 11606 -- In addition, if the task body is an activator, then a call to activate 11607 -- tasks is added at the start of the statements, before the call to 11608 -- Complete_Activation, and if in addition the task is a master then it 11609 -- must be established as a master. These calls are inserted and analyzed 11610 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is 11611 -- expanded. 11612 11613 -- There is one discriminal declaration line generated for each 11614 -- discriminant that is present to provide an easy reference point for 11615 -- discriminant references inside the body (see Exp_Ch2.Expand_Name). 11616 11617 -- Note on relationship to GNARLI definition. In the GNARLI definition, 11618 -- task body procedures have a profile (Arg : System.Address). That is 11619 -- needed because GNARLI has to use the same access-to-subprogram type 11620 -- for all task types. We depend here on knowing that in GNAT, passing 11621 -- an address argument by value is identical to passing a record value 11622 -- by access (in either case a single pointer is passed), so even though 11623 -- this procedure has the wrong profile. In fact it's all OK, since the 11624 -- callings sequence is identical. 11625 11626 procedure Expand_N_Task_Body (N : Node_Id) is 11627 Loc : constant Source_Ptr := Sloc (N); 11628 Ttyp : constant Entity_Id := Corresponding_Spec (N); 11629 Call : Node_Id; 11630 New_N : Node_Id; 11631 11632 Insert_Nod : Node_Id; 11633 -- Used to determine the proper location of wrapper body insertions 11634 11635 begin 11636 -- if no task body procedure, means we had an error in configurable 11637 -- run-time mode, and there is no point in proceeding further. 11638 11639 if No (Task_Body_Procedure (Ttyp)) then 11640 return; 11641 end if; 11642 11643 -- Add renaming declarations for discriminals and a declaration for the 11644 -- entry family index (if applicable). 11645 11646 Install_Private_Data_Declarations 11647 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N)); 11648 11649 -- Add a call to Abort_Undefer at the very beginning of the task 11650 -- body since this body is called with abort still deferred. 11651 11652 if Abort_Allowed then 11653 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 11654 Insert_Before 11655 (First (Statements (Handled_Statement_Sequence (N))), Call); 11656 Analyze (Call); 11657 end if; 11658 11659 -- The statement part has already been protected with an at_end and 11660 -- cleanup actions. The call to Complete_Activation must be placed 11661 -- at the head of the sequence of statements of that block. The 11662 -- declarations have been merged in this sequence of statements but 11663 -- the first real statement is accessible from the First_Real_Statement 11664 -- field (which was set for exactly this purpose). 11665 11666 if Restricted_Profile then 11667 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); 11668 else 11669 Call := Build_Runtime_Call (Loc, RE_Complete_Activation); 11670 end if; 11671 11672 Insert_Before 11673 (First_Real_Statement (Handled_Statement_Sequence (N)), Call); 11674 Analyze (Call); 11675 11676 New_N := 11677 Make_Subprogram_Body (Loc, 11678 Specification => Build_Task_Proc_Specification (Ttyp), 11679 Declarations => Declarations (N), 11680 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 11681 Set_Is_Task_Body_Procedure (New_N); 11682 11683 -- If the task contains generic instantiations, cleanup actions are 11684 -- delayed until after instantiation. Transfer the activation chain to 11685 -- the subprogram, to insure that the activation call is properly 11686 -- generated. It the task body contains inner tasks, indicate that the 11687 -- subprogram is a task master. 11688 11689 if Delay_Cleanups (Ttyp) then 11690 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); 11691 Set_Is_Task_Master (New_N, Is_Task_Master (N)); 11692 end if; 11693 11694 Rewrite (N, New_N); 11695 Analyze (N); 11696 11697 -- Set elaboration flag immediately after task body. If the body is a 11698 -- subunit, the flag is set in the declarative part containing the stub. 11699 11700 if Nkind (Parent (N)) /= N_Subunit then 11701 Insert_After (N, 11702 Make_Assignment_Statement (Loc, 11703 Name => 11704 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), 11705 Expression => New_Occurrence_Of (Standard_True, Loc))); 11706 end if; 11707 11708 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after 11709 -- the task body. At this point all wrapper specs have been created, 11710 -- frozen and included in the dispatch table for the task type. 11711 11712 if Ada_Version >= Ada_2005 then 11713 if Nkind (Parent (N)) = N_Subunit then 11714 Insert_Nod := Corresponding_Stub (Parent (N)); 11715 else 11716 Insert_Nod := N; 11717 end if; 11718 11719 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod); 11720 end if; 11721 end Expand_N_Task_Body; 11722 11723 ------------------------------------ 11724 -- Expand_N_Task_Type_Declaration -- 11725 ------------------------------------ 11726 11727 -- We have several things to do. First we must create a Boolean flag used 11728 -- to mark if the body is elaborated yet. This variable gets set to True 11729 -- when the body of the task is elaborated (we can't rely on the normal 11730 -- ABE mechanism for the task body, since we need to pass an access to 11731 -- this elaboration boolean to the runtime routines). 11732 11733 -- taskE : aliased Boolean := False; 11734 11735 -- Next a variable is declared to hold the task stack size (either the 11736 -- default : Unspecified_Size, or a value that is set by a pragma 11737 -- Storage_Size). If the value of the pragma Storage_Size is static, then 11738 -- the variable is initialized with this value: 11739 11740 -- taskZ : Size_Type := Unspecified_Size; 11741 -- or 11742 -- taskZ : Size_Type := Size_Type (size_expression); 11743 11744 -- Note: No variable is needed to hold the task relative deadline since 11745 -- its value would never be static because the parameter is of a private 11746 -- type (Ada.Real_Time.Time_Span). 11747 11748 -- Next we create a corresponding record type declaration used to represent 11749 -- values of this task. The general form of this type declaration is 11750 11751 -- type taskV (discriminants) is record 11752 -- _Task_Id : Task_Id; 11753 -- entry_family : array (bounds) of Void; 11754 -- _Priority : Integer := priority_expression; 11755 -- _Size : Size_Type := size_expression; 11756 -- _Secondary_Stack_Size : Size_Type := size_expression; 11757 -- _Task_Info : Task_Info_Type := task_info_expression; 11758 -- _CPU : Integer := cpu_range_expression; 11759 -- _Relative_Deadline : Time_Span := time_span_expression; 11760 -- _Domain : Dispatching_Domain := dd_expression; 11761 -- end record; 11762 11763 -- The discriminants are present only if the corresponding task type has 11764 -- discriminants, and they exactly mirror the task type discriminants. 11765 11766 -- The Id field is always present. It contains the Task_Id value, as set by 11767 -- the call to Create_Task. Note that although the task is limited, the 11768 -- task value record type is not limited, so there is no problem in passing 11769 -- this field as an out parameter to Create_Task. 11770 11771 -- One entry_family component is present for each entry family in the task 11772 -- definition. The bounds correspond to the bounds of the entry family 11773 -- (which may depend on discriminants). The element type is void, since we 11774 -- only need the bounds information for determining the entry index. Note 11775 -- that the use of an anonymous array would normally be illegal in this 11776 -- context, but this is a parser check, and the semantics is quite prepared 11777 -- to handle such a case. 11778 11779 -- The _Size field is present only if a Storage_Size pragma appears in the 11780 -- task definition. The expression captures the argument that was present 11781 -- in the pragma, and is used to override the task stack size otherwise 11782 -- associated with the task type. 11783 11784 -- The _Secondary_Stack_Size field is present only the task entity has a 11785 -- Secondary_Stack_Size rep item. It will be filled at the freeze point, 11786 -- when the record init proc is built, to capture the expression of the 11787 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot 11788 -- be filled here since aspect evaluations are delayed till the freeze 11789 -- point. 11790 11791 -- The _Priority field is present only if the task entity has a Priority or 11792 -- Interrupt_Priority rep item (pragma, aspect specification or attribute 11793 -- definition clause). It will be filled at the freeze point, when the 11794 -- record init proc is built, to capture the expression of the rep item 11795 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11796 -- here since aspect evaluations are delayed till the freeze point. 11797 11798 -- The _Task_Info field is present only if a Task_Info pragma appears in 11799 -- the task definition. The expression captures the argument that was 11800 -- present in the pragma, and is used to provide the Task_Image parameter 11801 -- to the call to Create_Task. 11802 11803 -- The _CPU field is present only if the task entity has a CPU rep item 11804 -- (pragma, aspect specification or attribute definition clause). It will 11805 -- be filled at the freeze point, when the record init proc is built, to 11806 -- capture the expression of the rep item (see Build_Record_Init_Proc in 11807 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations 11808 -- are delayed till the freeze point. 11809 11810 -- The _Relative_Deadline field is present only if a Relative_Deadline 11811 -- pragma appears in the task definition. The expression captures the 11812 -- argument that was present in the pragma, and is used to provide the 11813 -- Relative_Deadline parameter to the call to Create_Task. 11814 11815 -- The _Domain field is present only if the task entity has a 11816 -- Dispatching_Domain rep item (pragma, aspect specification or attribute 11817 -- definition clause). It will be filled at the freeze point, when the 11818 -- record init proc is built, to capture the expression of the rep item 11819 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11820 -- here since aspect evaluations are delayed till the freeze point. 11821 11822 -- When a task is declared, an instance of the task value record is 11823 -- created. The elaboration of this declaration creates the correct bounds 11824 -- for the entry families, and also evaluates the size, priority, and 11825 -- task_Info expressions if needed. The initialization routine for the task 11826 -- type itself then calls Create_Task with appropriate parameters to 11827 -- initialize the value of the Task_Id field. 11828 11829 -- Note: the address of this record is passed as the "Discriminants" 11830 -- parameter for Create_Task. Since Create_Task merely passes this onto the 11831 -- body procedure, it does not matter that it does not quite match the 11832 -- GNARLI model of what is being passed (the record contains more than just 11833 -- the discriminants, but the discriminants can be found from the record 11834 -- value). 11835 11836 -- The Entity_Id for this created record type is placed in the 11837 -- Corresponding_Record_Type field of the associated task type entity. 11838 11839 -- Next we create a procedure specification for the task body procedure: 11840 11841 -- procedure taskB (_Task : access taskV); 11842 11843 -- Note that this must come after the record type declaration, since 11844 -- the spec refers to this type. It turns out that the initialization 11845 -- procedure for the value type references the task body spec, but that's 11846 -- fine, since it won't be generated till the freeze point for the type, 11847 -- which is certainly after the task body spec declaration. 11848 11849 -- Finally, we set the task index value field of the entry attribute in 11850 -- the case of a simple entry. 11851 11852 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is 11853 Loc : constant Source_Ptr := Sloc (N); 11854 TaskId : constant Entity_Id := Defining_Identifier (N); 11855 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); 11856 Tasknm : constant Name_Id := Chars (Tasktyp); 11857 Taskdef : constant Node_Id := Task_Definition (N); 11858 11859 Body_Decl : Node_Id; 11860 Cdecls : List_Id; 11861 Decl_Stack : Node_Id; 11862 Decl_SS : Node_Id; 11863 Elab_Decl : Node_Id; 11864 Ent_Stack : Entity_Id; 11865 Proc_Spec : Node_Id; 11866 Rec_Decl : Node_Id; 11867 Rec_Ent : Entity_Id; 11868 Size_Decl : Entity_Id; 11869 Task_Size : Node_Id; 11870 11871 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id; 11872 -- Searches the task definition T for the first occurrence of the pragma 11873 -- Relative Deadline. The caller has ensured that the pragma is present 11874 -- in the task definition. Note that this routine cannot be implemented 11875 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are 11876 -- not chained because their expansion into a procedure call statement 11877 -- would cause a break in the chain. 11878 11879 ---------------------------------- 11880 -- Get_Relative_Deadline_Pragma -- 11881 ---------------------------------- 11882 11883 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is 11884 N : Node_Id; 11885 11886 begin 11887 N := First (Visible_Declarations (T)); 11888 while Present (N) loop 11889 if Nkind (N) = N_Pragma 11890 and then Pragma_Name (N) = Name_Relative_Deadline 11891 then 11892 return N; 11893 end if; 11894 11895 Next (N); 11896 end loop; 11897 11898 N := First (Private_Declarations (T)); 11899 while Present (N) loop 11900 if Nkind (N) = N_Pragma 11901 and then Pragma_Name (N) = Name_Relative_Deadline 11902 then 11903 return N; 11904 end if; 11905 11906 Next (N); 11907 end loop; 11908 11909 raise Program_Error; 11910 end Get_Relative_Deadline_Pragma; 11911 11912 -- Start of processing for Expand_N_Task_Type_Declaration 11913 11914 begin 11915 -- If already expanded, nothing to do 11916 11917 if Present (Corresponding_Record_Type (Tasktyp)) then 11918 return; 11919 end if; 11920 11921 -- Here we will do the expansion 11922 11923 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); 11924 11925 Rec_Ent := Defining_Identifier (Rec_Decl); 11926 Cdecls := Component_Items (Component_List 11927 (Type_Definition (Rec_Decl))); 11928 11929 Qualify_Entity_Names (N); 11930 11931 -- First create the elaboration variable 11932 11933 Elab_Decl := 11934 Make_Object_Declaration (Loc, 11935 Defining_Identifier => 11936 Make_Defining_Identifier (Sloc (Tasktyp), 11937 Chars => New_External_Name (Tasknm, 'E')), 11938 Aliased_Present => True, 11939 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 11940 Expression => New_Occurrence_Of (Standard_False, Loc)); 11941 11942 Insert_After (N, Elab_Decl); 11943 11944 -- Next create the declaration of the size variable (tasknmZ) 11945 11946 Set_Storage_Size_Variable (Tasktyp, 11947 Make_Defining_Identifier (Sloc (Tasktyp), 11948 Chars => New_External_Name (Tasknm, 'Z'))); 11949 11950 if Present (Taskdef) 11951 and then Has_Storage_Size_Pragma (Taskdef) 11952 and then 11953 Is_OK_Static_Expression 11954 (Expression 11955 (First (Pragma_Argument_Associations 11956 (Get_Rep_Pragma (TaskId, Name_Storage_Size))))) 11957 then 11958 Size_Decl := 11959 Make_Object_Declaration (Loc, 11960 Defining_Identifier => Storage_Size_Variable (Tasktyp), 11961 Object_Definition => 11962 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 11963 Expression => 11964 Convert_To (RTE (RE_Size_Type), 11965 Relocate_Node 11966 (Expression (First (Pragma_Argument_Associations 11967 (Get_Rep_Pragma 11968 (TaskId, Name_Storage_Size))))))); 11969 11970 else 11971 Size_Decl := 11972 Make_Object_Declaration (Loc, 11973 Defining_Identifier => Storage_Size_Variable (Tasktyp), 11974 Object_Definition => 11975 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 11976 Expression => 11977 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 11978 end if; 11979 11980 Insert_After (Elab_Decl, Size_Decl); 11981 11982 -- Next build the rest of the corresponding record declaration. This is 11983 -- done last, since the corresponding record initialization procedure 11984 -- will reference the previously created entities. 11985 11986 -- Fill in the component declarations -- first the _Task_Id field 11987 11988 Append_To (Cdecls, 11989 Make_Component_Declaration (Loc, 11990 Defining_Identifier => 11991 Make_Defining_Identifier (Loc, Name_uTask_Id), 11992 Component_Definition => 11993 Make_Component_Definition (Loc, 11994 Aliased_Present => False, 11995 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id), 11996 Loc)))); 11997 11998 -- Declare static ATCB (that is, created by the expander) if we are 11999 -- using the Restricted run time. 12000 12001 if Restricted_Profile then 12002 Append_To (Cdecls, 12003 Make_Component_Declaration (Loc, 12004 Defining_Identifier => 12005 Make_Defining_Identifier (Loc, Name_uATCB), 12006 12007 Component_Definition => 12008 Make_Component_Definition (Loc, 12009 Aliased_Present => True, 12010 Subtype_Indication => Make_Subtype_Indication (Loc, 12011 Subtype_Mark => 12012 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc), 12013 12014 Constraint => 12015 Make_Index_Or_Discriminant_Constraint (Loc, 12016 Constraints => 12017 New_List (Make_Integer_Literal (Loc, 0))))))); 12018 12019 end if; 12020 12021 -- Declare static stack (that is, created by the expander) if we are 12022 -- using the Restricted run time on a bare board configuration. 12023 12024 if Restricted_Profile and then Preallocated_Stacks_On_Target then 12025 12026 -- First we need to extract the appropriate stack size 12027 12028 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack); 12029 12030 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 12031 declare 12032 Expr_N : constant Node_Id := 12033 Expression (First ( 12034 Pragma_Argument_Associations ( 12035 Get_Rep_Pragma (TaskId, Name_Storage_Size)))); 12036 Etyp : constant Entity_Id := Etype (Expr_N); 12037 P : constant Node_Id := Parent (Expr_N); 12038 12039 begin 12040 -- The stack is defined inside the corresponding record. 12041 -- Therefore if the size of the stack is set by means of 12042 -- a discriminant, we must reference the discriminant of the 12043 -- corresponding record type. 12044 12045 if Nkind (Expr_N) in N_Has_Entity 12046 and then Present (Discriminal_Link (Entity (Expr_N))) 12047 then 12048 Task_Size := 12049 New_Occurrence_Of 12050 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))), 12051 Loc); 12052 Set_Parent (Task_Size, P); 12053 Set_Etype (Task_Size, Etyp); 12054 Set_Analyzed (Task_Size); 12055 12056 else 12057 Task_Size := New_Copy_Tree (Expr_N); 12058 end if; 12059 end; 12060 12061 else 12062 Task_Size := 12063 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc); 12064 end if; 12065 12066 Decl_Stack := Make_Component_Declaration (Loc, 12067 Defining_Identifier => Ent_Stack, 12068 12069 Component_Definition => 12070 Make_Component_Definition (Loc, 12071 Aliased_Present => True, 12072 Subtype_Indication => Make_Subtype_Indication (Loc, 12073 Subtype_Mark => 12074 New_Occurrence_Of (RTE (RE_Storage_Array), Loc), 12075 12076 Constraint => 12077 Make_Index_Or_Discriminant_Constraint (Loc, 12078 Constraints => New_List (Make_Range (Loc, 12079 Low_Bound => Make_Integer_Literal (Loc, 1), 12080 High_Bound => Convert_To (RTE (RE_Storage_Offset), 12081 Task_Size))))))); 12082 12083 Append_To (Cdecls, Decl_Stack); 12084 12085 -- The appropriate alignment for the stack is ensured by the run-time 12086 -- code in charge of task creation. 12087 12088 end if; 12089 12090 -- Declare a static secondary stack if the conditions for a statically 12091 -- generated stack are met. 12092 12093 if Create_Secondary_Stack_For_Task (TaskId) then 12094 declare 12095 Size_Expr : constant Node_Id := 12096 Expression (First ( 12097 Pragma_Argument_Associations ( 12098 Get_Rep_Pragma (TaskId, 12099 Name_Secondary_Stack_Size)))); 12100 12101 Stack_Size : Node_Id; 12102 12103 begin 12104 -- The secondary stack is defined inside the corresponding 12105 -- record. Therefore if the size of the stack is set by means 12106 -- of a discriminant, we must reference the discriminant of the 12107 -- corresponding record type. 12108 12109 if Nkind (Size_Expr) in N_Has_Entity 12110 and then Present (Discriminal_Link (Entity (Size_Expr))) 12111 then 12112 Stack_Size := 12113 New_Occurrence_Of 12114 (CR_Discriminant (Discriminal_Link (Entity (Size_Expr))), 12115 Loc); 12116 Set_Parent (Stack_Size, Parent (Size_Expr)); 12117 Set_Etype (Stack_Size, Etype (Size_Expr)); 12118 Set_Analyzed (Stack_Size); 12119 12120 else 12121 Stack_Size := New_Copy_Tree (Size_Expr); 12122 end if; 12123 12124 -- Create the secondary stack for the task 12125 12126 Decl_SS := 12127 Make_Component_Declaration (Loc, 12128 Defining_Identifier => 12129 Make_Defining_Identifier (Loc, Name_uSecondary_Stack), 12130 Component_Definition => 12131 Make_Component_Definition (Loc, 12132 Aliased_Present => True, 12133 Subtype_Indication => 12134 Make_Subtype_Indication (Loc, 12135 Subtype_Mark => 12136 New_Occurrence_Of (RTE (RE_SS_Stack), Loc), 12137 Constraint => 12138 Make_Index_Or_Discriminant_Constraint (Loc, 12139 Constraints => New_List ( 12140 Convert_To (RTE (RE_Size_Type), 12141 Stack_Size)))))); 12142 12143 Append_To (Cdecls, Decl_SS); 12144 end; 12145 end if; 12146 12147 -- Add components for entry families 12148 12149 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); 12150 12151 -- Add the _Priority component if a Interrupt_Priority or Priority rep 12152 -- item is present. 12153 12154 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then 12155 Append_To (Cdecls, 12156 Make_Component_Declaration (Loc, 12157 Defining_Identifier => 12158 Make_Defining_Identifier (Loc, Name_uPriority), 12159 Component_Definition => 12160 Make_Component_Definition (Loc, 12161 Aliased_Present => False, 12162 Subtype_Indication => 12163 New_Occurrence_Of (Standard_Integer, Loc)))); 12164 end if; 12165 12166 -- Add the _Size component if a Storage_Size pragma is present 12167 12168 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 12169 Append_To (Cdecls, 12170 Make_Component_Declaration (Loc, 12171 Defining_Identifier => 12172 Make_Defining_Identifier (Loc, Name_uSize), 12173 12174 Component_Definition => 12175 Make_Component_Definition (Loc, 12176 Aliased_Present => False, 12177 Subtype_Indication => 12178 New_Occurrence_Of (RTE (RE_Size_Type), Loc)), 12179 12180 Expression => 12181 Convert_To (RTE (RE_Size_Type), 12182 New_Copy_Tree ( 12183 Expression (First ( 12184 Pragma_Argument_Associations ( 12185 Get_Rep_Pragma (TaskId, Name_Storage_Size)))))))); 12186 end if; 12187 12188 -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size 12189 -- pragma is present. 12190 12191 if Has_Rep_Pragma 12192 (TaskId, Name_Secondary_Stack_Size, Check_Parents => False) 12193 then 12194 Append_To (Cdecls, 12195 Make_Component_Declaration (Loc, 12196 Defining_Identifier => 12197 Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size), 12198 12199 Component_Definition => 12200 Make_Component_Definition (Loc, 12201 Aliased_Present => False, 12202 Subtype_Indication => 12203 New_Occurrence_Of (RTE (RE_Size_Type), Loc)))); 12204 end if; 12205 12206 -- Add the _Task_Info component if a Task_Info pragma is present 12207 12208 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then 12209 Append_To (Cdecls, 12210 Make_Component_Declaration (Loc, 12211 Defining_Identifier => 12212 Make_Defining_Identifier (Loc, Name_uTask_Info), 12213 12214 Component_Definition => 12215 Make_Component_Definition (Loc, 12216 Aliased_Present => False, 12217 Subtype_Indication => 12218 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)), 12219 12220 Expression => New_Copy ( 12221 Expression (First ( 12222 Pragma_Argument_Associations ( 12223 Get_Rep_Pragma 12224 (TaskId, Name_Task_Info, Check_Parents => False))))))); 12225 end if; 12226 12227 -- Add the _CPU component if a CPU rep item is present 12228 12229 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then 12230 Append_To (Cdecls, 12231 Make_Component_Declaration (Loc, 12232 Defining_Identifier => 12233 Make_Defining_Identifier (Loc, Name_uCPU), 12234 12235 Component_Definition => 12236 Make_Component_Definition (Loc, 12237 Aliased_Present => False, 12238 Subtype_Indication => 12239 New_Occurrence_Of (RTE (RE_CPU_Range), Loc)))); 12240 end if; 12241 12242 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is 12243 -- present. If we are using a restricted run time this component will 12244 -- not be added (deadlines are not allowed by the Ravenscar profile), 12245 -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF 12246 -- profile). 12247 12248 if (not Restricted_Profile or else Task_Dispatching_Policy = 'E') 12249 and then Present (Taskdef) 12250 and then Has_Relative_Deadline_Pragma (Taskdef) 12251 then 12252 Append_To (Cdecls, 12253 Make_Component_Declaration (Loc, 12254 Defining_Identifier => 12255 Make_Defining_Identifier (Loc, Name_uRelative_Deadline), 12256 12257 Component_Definition => 12258 Make_Component_Definition (Loc, 12259 Aliased_Present => False, 12260 Subtype_Indication => 12261 New_Occurrence_Of (RTE (RE_Time_Span), Loc)), 12262 12263 Expression => 12264 Convert_To (RTE (RE_Time_Span), 12265 New_Copy_Tree ( 12266 Expression (First ( 12267 Pragma_Argument_Associations ( 12268 Get_Relative_Deadline_Pragma (Taskdef)))))))); 12269 end if; 12270 12271 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep 12272 -- item is present. If we are using a restricted run time this component 12273 -- will not be added (dispatching domains are not allowed by the 12274 -- Ravenscar profile). 12275 12276 if not Restricted_Profile 12277 and then 12278 Has_Rep_Item 12279 (TaskId, Name_Dispatching_Domain, Check_Parents => False) 12280 then 12281 Append_To (Cdecls, 12282 Make_Component_Declaration (Loc, 12283 Defining_Identifier => 12284 Make_Defining_Identifier (Loc, Name_uDispatching_Domain), 12285 12286 Component_Definition => 12287 Make_Component_Definition (Loc, 12288 Aliased_Present => False, 12289 Subtype_Indication => 12290 New_Occurrence_Of 12291 (RTE (RE_Dispatching_Domain_Access), Loc)))); 12292 end if; 12293 12294 Insert_After (Size_Decl, Rec_Decl); 12295 12296 -- Analyze the record declaration immediately after construction, 12297 -- because the initialization procedure is needed for single task 12298 -- declarations before the next entity is analyzed. 12299 12300 Analyze (Rec_Decl); 12301 12302 -- Create the declaration of the task body procedure 12303 12304 Proc_Spec := Build_Task_Proc_Specification (Tasktyp); 12305 Body_Decl := 12306 Make_Subprogram_Declaration (Loc, 12307 Specification => Proc_Spec); 12308 Set_Is_Task_Body_Procedure (Body_Decl); 12309 12310 Insert_After (Rec_Decl, Body_Decl); 12311 12312 -- The subprogram does not comes from source, so we have to indicate the 12313 -- need for debugging information explicitly. 12314 12315 if Comes_From_Source (Original_Node (N)) then 12316 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec)); 12317 end if; 12318 12319 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before 12320 -- the corresponding record has been frozen. 12321 12322 if Ada_Version >= Ada_2005 then 12323 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl); 12324 end if; 12325 12326 -- Ada 2005 (AI-345): We must defer freezing to allow further 12327 -- declaration of primitive subprograms covering task interfaces 12328 12329 if Ada_Version <= Ada_95 then 12330 12331 -- Now we can freeze the corresponding record. This needs manually 12332 -- freezing, since it is really part of the task type, and the task 12333 -- type is frozen at this stage. We of course need the initialization 12334 -- procedure for this corresponding record type and we won't get it 12335 -- in time if we don't freeze now. 12336 12337 declare 12338 L : constant List_Id := Freeze_Entity (Rec_Ent, N); 12339 begin 12340 if Is_Non_Empty_List (L) then 12341 Insert_List_After (Body_Decl, L); 12342 end if; 12343 end; 12344 end if; 12345 12346 -- Complete the expansion of access types to the current task type, if 12347 -- any were declared. 12348 12349 Expand_Previous_Access_Type (Tasktyp); 12350 12351 -- Create wrappers for entries that have contract cases, preconditions 12352 -- and postconditions. 12353 12354 declare 12355 Ent : Entity_Id; 12356 12357 begin 12358 Ent := First_Entity (Tasktyp); 12359 while Present (Ent) loop 12360 if Ekind_In (Ent, E_Entry, E_Entry_Family) then 12361 Build_Contract_Wrapper (Ent, N); 12362 end if; 12363 12364 Next_Entity (Ent); 12365 end loop; 12366 end; 12367 end Expand_N_Task_Type_Declaration; 12368 12369 ------------------------------- 12370 -- Expand_N_Timed_Entry_Call -- 12371 ------------------------------- 12372 12373 -- A timed entry call in normal case is not implemented using ATC mechanism 12374 -- anymore for efficiency reason. 12375 12376 -- select 12377 -- T.E; 12378 -- S1; 12379 -- or 12380 -- delay D; 12381 -- S2; 12382 -- end select; 12383 12384 -- is expanded as follows: 12385 12386 -- 1) When T.E is a task entry_call; 12387 12388 -- declare 12389 -- B : Boolean; 12390 -- X : Task_Entry_Index := <entry index>; 12391 -- DX : Duration := To_Duration (D); 12392 -- M : Delay_Mode := <discriminant>; 12393 -- P : parms := (parm, parm, parm); 12394 12395 -- begin 12396 -- Timed_Protected_Entry_Call 12397 -- (<acceptor-task>, X, P'Address, DX, M, B); 12398 -- if B then 12399 -- S1; 12400 -- else 12401 -- S2; 12402 -- end if; 12403 -- end; 12404 12405 -- 2) When T.E is a protected entry_call; 12406 12407 -- declare 12408 -- B : Boolean; 12409 -- X : Protected_Entry_Index := <entry index>; 12410 -- DX : Duration := To_Duration (D); 12411 -- M : Delay_Mode := <discriminant>; 12412 -- P : parms := (parm, parm, parm); 12413 12414 -- begin 12415 -- Timed_Protected_Entry_Call 12416 -- (<object>'unchecked_access, X, P'Address, DX, M, B); 12417 -- if B then 12418 -- S1; 12419 -- else 12420 -- S2; 12421 -- end if; 12422 -- end; 12423 12424 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there 12425 -- is no delay and the triggering statements are executed. We first 12426 -- determine the kind of the triggering call and then execute a 12427 -- synchronized operation or a direct call. 12428 12429 -- declare 12430 -- B : Boolean := False; 12431 -- C : Ada.Tags.Prim_Op_Kind; 12432 -- DX : Duration := To_Duration (D) 12433 -- K : Ada.Tags.Tagged_Kind := 12434 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 12435 -- M : Integer :=...; 12436 -- P : Parameters := (Param1 .. ParamN); 12437 -- S : Integer; 12438 12439 -- begin 12440 -- if K = Ada.Tags.TK_Limited_Tagged 12441 -- or else K = Ada.Tags.TK_Tagged 12442 -- then 12443 -- <dispatching-call>; 12444 -- B := True; 12445 12446 -- else 12447 -- S := 12448 -- Ada.Tags.Get_Offset_Index 12449 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 12450 12451 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B); 12452 12453 -- if C = POK_Protected_Entry 12454 -- or else C = POK_Task_Entry 12455 -- then 12456 -- Param1 := P.Param1; 12457 -- ... 12458 -- ParamN := P.ParamN; 12459 -- end if; 12460 12461 -- if B then 12462 -- if C = POK_Procedure 12463 -- or else C = POK_Protected_Procedure 12464 -- or else C = POK_Task_Procedure 12465 -- then 12466 -- <dispatching-call>; 12467 -- end if; 12468 -- end if; 12469 -- end if; 12470 12471 -- if B then 12472 -- <triggering-statements> 12473 -- else 12474 -- <timed-statements> 12475 -- end if; 12476 -- end; 12477 12478 -- The triggering statement and the sequence of timed statements have not 12479 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain 12480 -- global references if within an instantiation. 12481 12482 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is 12483 Loc : constant Source_Ptr := Sloc (N); 12484 12485 Actuals : List_Id; 12486 Blk_Typ : Entity_Id; 12487 Call : Node_Id; 12488 Call_Ent : Entity_Id; 12489 Conc_Typ_Stmts : List_Id; 12490 Concval : Node_Id := Empty; -- init to avoid warning 12491 D_Alt : constant Node_Id := Delay_Alternative (N); 12492 D_Conv : Node_Id; 12493 D_Disc : Node_Id; 12494 D_Stat : Node_Id := Delay_Statement (D_Alt); 12495 D_Stats : List_Id; 12496 D_Type : Entity_Id; 12497 Decls : List_Id; 12498 Dummy : Node_Id; 12499 E_Alt : constant Node_Id := Entry_Call_Alternative (N); 12500 E_Call : Node_Id := Entry_Call_Statement (E_Alt); 12501 E_Stats : List_Id; 12502 Ename : Node_Id; 12503 Formals : List_Id; 12504 Index : Node_Id; 12505 Is_Disp_Select : Boolean; 12506 Lim_Typ_Stmts : List_Id; 12507 N_Stats : List_Id; 12508 Obj : Entity_Id; 12509 Param : Node_Id; 12510 Params : List_Id; 12511 Stmt : Node_Id; 12512 Stmts : List_Id; 12513 Unpack : List_Id; 12514 12515 B : Entity_Id; -- Call status flag 12516 C : Entity_Id; -- Call kind 12517 D : Entity_Id; -- Delay 12518 K : Entity_Id; -- Tagged kind 12519 M : Entity_Id; -- Delay mode 12520 P : Entity_Id; -- Parameter block 12521 S : Entity_Id; -- Primitive operation slot 12522 12523 -- Start of processing for Expand_N_Timed_Entry_Call 12524 12525 begin 12526 -- Under the Ravenscar profile, timed entry calls are excluded. An error 12527 -- was already reported on spec, so do not attempt to expand the call. 12528 12529 if Restriction_Active (No_Select_Statements) then 12530 return; 12531 end if; 12532 12533 Process_Statements_For_Controlled_Objects (E_Alt); 12534 Process_Statements_For_Controlled_Objects (D_Alt); 12535 12536 Ensure_Statement_Present (Sloc (D_Stat), D_Alt); 12537 12538 -- Retrieve E_Stats and D_Stats now because the finalization machinery 12539 -- may wrap them in blocks. 12540 12541 E_Stats := Statements (E_Alt); 12542 D_Stats := Statements (D_Alt); 12543 12544 -- The arguments in the call may require dynamic allocation, and the 12545 -- call statement may have been transformed into a block. The block 12546 -- may contain additional declarations for internal entities, and the 12547 -- original call is found by sequential search. 12548 12549 if Nkind (E_Call) = N_Block_Statement then 12550 E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); 12551 while not Nkind_In (E_Call, N_Procedure_Call_Statement, 12552 N_Entry_Call_Statement) 12553 loop 12554 Next (E_Call); 12555 end loop; 12556 end if; 12557 12558 Is_Disp_Select := 12559 Ada_Version >= Ada_2005 12560 and then Nkind (E_Call) = N_Procedure_Call_Statement; 12561 12562 if Is_Disp_Select then 12563 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals); 12564 Decls := New_List; 12565 12566 Stmts := New_List; 12567 12568 -- Generate: 12569 -- B : Boolean := False; 12570 12571 B := Build_B (Loc, Decls); 12572 12573 -- Generate: 12574 -- C : Ada.Tags.Prim_Op_Kind; 12575 12576 C := Build_C (Loc, Decls); 12577 12578 -- Because the analysis of all statements was disabled, manually 12579 -- analyze the delay statement. 12580 12581 Analyze (D_Stat); 12582 D_Stat := Original_Node (D_Stat); 12583 12584 else 12585 -- Build an entry call using Simple_Entry_Call 12586 12587 Extract_Entry (E_Call, Concval, Ename, Index); 12588 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); 12589 12590 Decls := Declarations (E_Call); 12591 Stmts := Statements (Handled_Statement_Sequence (E_Call)); 12592 12593 if No (Decls) then 12594 Decls := New_List; 12595 end if; 12596 12597 -- Generate: 12598 -- B : Boolean; 12599 12600 B := Make_Defining_Identifier (Loc, Name_uB); 12601 12602 Prepend_To (Decls, 12603 Make_Object_Declaration (Loc, 12604 Defining_Identifier => B, 12605 Object_Definition => 12606 New_Occurrence_Of (Standard_Boolean, Loc))); 12607 end if; 12608 12609 -- Duration and mode processing 12610 12611 D_Type := Base_Type (Etype (Expression (D_Stat))); 12612 12613 -- Use the type of the delay expression (Calendar or Real_Time) to 12614 -- generate the appropriate conversion. 12615 12616 if Nkind (D_Stat) = N_Delay_Relative_Statement then 12617 D_Disc := Make_Integer_Literal (Loc, 0); 12618 D_Conv := Relocate_Node (Expression (D_Stat)); 12619 12620 elsif Is_RTE (D_Type, RO_CA_Time) then 12621 D_Disc := Make_Integer_Literal (Loc, 1); 12622 D_Conv := 12623 Make_Function_Call (Loc, 12624 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 12625 Parameter_Associations => 12626 New_List (New_Copy (Expression (D_Stat)))); 12627 12628 else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); 12629 D_Disc := Make_Integer_Literal (Loc, 2); 12630 D_Conv := 12631 Make_Function_Call (Loc, 12632 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 12633 Parameter_Associations => 12634 New_List (New_Copy (Expression (D_Stat)))); 12635 end if; 12636 12637 D := Make_Temporary (Loc, 'D'); 12638 12639 -- Generate: 12640 -- D : Duration; 12641 12642 Append_To (Decls, 12643 Make_Object_Declaration (Loc, 12644 Defining_Identifier => D, 12645 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc))); 12646 12647 M := Make_Temporary (Loc, 'M'); 12648 12649 -- Generate: 12650 -- M : Integer := (0 | 1 | 2); 12651 12652 Append_To (Decls, 12653 Make_Object_Declaration (Loc, 12654 Defining_Identifier => M, 12655 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 12656 Expression => D_Disc)); 12657 12658 -- Do the assignment at this stage only because the evaluation of the 12659 -- expression must not occur earlier (see ACVC C97302A). 12660 12661 Append_To (Stmts, 12662 Make_Assignment_Statement (Loc, 12663 Name => New_Occurrence_Of (D, Loc), 12664 Expression => D_Conv)); 12665 12666 -- Parameter block processing 12667 12668 -- Manually create the parameter block for dispatching calls. In the 12669 -- case of entries, the block has already been created during the call 12670 -- to Build_Simple_Entry_Call. 12671 12672 if Is_Disp_Select then 12673 12674 -- Tagged kind processing, generate: 12675 -- K : Ada.Tags.Tagged_Kind := 12676 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>)); 12677 12678 K := Build_K (Loc, Decls, Obj); 12679 12680 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 12681 P := 12682 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 12683 12684 -- Dispatch table slot processing, generate: 12685 -- S : Integer; 12686 12687 S := Build_S (Loc, Decls); 12688 12689 -- Generate: 12690 -- S := Ada.Tags.Get_Offset_Index 12691 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 12692 12693 Conc_Typ_Stmts := 12694 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 12695 12696 -- Generate: 12697 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B); 12698 12699 -- where Obj is the controlling formal parameter, S is the dispatch 12700 -- table slot number of the dispatching operation, P is the wrapped 12701 -- parameter block, D is the duration, M is the duration mode, C is 12702 -- the call kind and B is the call status. 12703 12704 Params := New_List; 12705 12706 Append_To (Params, New_Copy_Tree (Obj)); 12707 Append_To (Params, New_Occurrence_Of (S, Loc)); 12708 Append_To (Params, 12709 Make_Attribute_Reference (Loc, 12710 Prefix => New_Occurrence_Of (P, Loc), 12711 Attribute_Name => Name_Address)); 12712 Append_To (Params, New_Occurrence_Of (D, Loc)); 12713 Append_To (Params, New_Occurrence_Of (M, Loc)); 12714 Append_To (Params, New_Occurrence_Of (C, Loc)); 12715 Append_To (Params, New_Occurrence_Of (B, Loc)); 12716 12717 Append_To (Conc_Typ_Stmts, 12718 Make_Procedure_Call_Statement (Loc, 12719 Name => 12720 New_Occurrence_Of 12721 (Find_Prim_Op 12722 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc), 12723 Parameter_Associations => Params)); 12724 12725 -- Generate: 12726 -- if C = POK_Protected_Entry 12727 -- or else C = POK_Task_Entry 12728 -- then 12729 -- Param1 := P.Param1; 12730 -- ... 12731 -- ParamN := P.ParamN; 12732 -- end if; 12733 12734 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 12735 12736 -- Generate the if statement only when the packed parameters need 12737 -- explicit assignments to their corresponding actuals. 12738 12739 if Present (Unpack) then 12740 Append_To (Conc_Typ_Stmts, 12741 Make_Implicit_If_Statement (N, 12742 12743 Condition => 12744 Make_Or_Else (Loc, 12745 Left_Opnd => 12746 Make_Op_Eq (Loc, 12747 Left_Opnd => New_Occurrence_Of (C, Loc), 12748 Right_Opnd => 12749 New_Occurrence_Of 12750 (RTE (RE_POK_Protected_Entry), Loc)), 12751 12752 Right_Opnd => 12753 Make_Op_Eq (Loc, 12754 Left_Opnd => New_Occurrence_Of (C, Loc), 12755 Right_Opnd => 12756 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 12757 12758 Then_Statements => Unpack)); 12759 end if; 12760 12761 -- Generate: 12762 12763 -- if B then 12764 -- if C = POK_Procedure 12765 -- or else C = POK_Protected_Procedure 12766 -- or else C = POK_Task_Procedure 12767 -- then 12768 -- <dispatching-call> 12769 -- end if; 12770 -- end if; 12771 12772 N_Stats := New_List ( 12773 Make_Implicit_If_Statement (N, 12774 Condition => 12775 Make_Or_Else (Loc, 12776 Left_Opnd => 12777 Make_Op_Eq (Loc, 12778 Left_Opnd => New_Occurrence_Of (C, Loc), 12779 Right_Opnd => 12780 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 12781 12782 Right_Opnd => 12783 Make_Or_Else (Loc, 12784 Left_Opnd => 12785 Make_Op_Eq (Loc, 12786 Left_Opnd => New_Occurrence_Of (C, Loc), 12787 Right_Opnd => 12788 New_Occurrence_Of (RTE ( 12789 RE_POK_Protected_Procedure), Loc)), 12790 Right_Opnd => 12791 Make_Op_Eq (Loc, 12792 Left_Opnd => New_Occurrence_Of (C, Loc), 12793 Right_Opnd => 12794 New_Occurrence_Of 12795 (RTE (RE_POK_Task_Procedure), Loc)))), 12796 12797 Then_Statements => New_List (E_Call))); 12798 12799 Append_To (Conc_Typ_Stmts, 12800 Make_Implicit_If_Statement (N, 12801 Condition => New_Occurrence_Of (B, Loc), 12802 Then_Statements => N_Stats)); 12803 12804 -- Generate: 12805 -- <dispatching-call>; 12806 -- B := True; 12807 12808 Lim_Typ_Stmts := 12809 New_List (New_Copy_Tree (E_Call), 12810 Make_Assignment_Statement (Loc, 12811 Name => New_Occurrence_Of (B, Loc), 12812 Expression => New_Occurrence_Of (Standard_True, Loc))); 12813 12814 -- Generate: 12815 -- if K = Ada.Tags.TK_Limited_Tagged 12816 -- or else K = Ada.Tags.TK_Tagged 12817 -- then 12818 -- Lim_Typ_Stmts 12819 -- else 12820 -- Conc_Typ_Stmts 12821 -- end if; 12822 12823 Append_To (Stmts, 12824 Make_Implicit_If_Statement (N, 12825 Condition => Build_Dispatching_Tag_Check (K, N), 12826 Then_Statements => Lim_Typ_Stmts, 12827 Else_Statements => Conc_Typ_Stmts)); 12828 12829 -- Generate: 12830 12831 -- if B then 12832 -- <triggering-statements> 12833 -- else 12834 -- <timed-statements> 12835 -- end if; 12836 12837 Append_To (Stmts, 12838 Make_Implicit_If_Statement (N, 12839 Condition => New_Occurrence_Of (B, Loc), 12840 Then_Statements => E_Stats, 12841 Else_Statements => D_Stats)); 12842 12843 else 12844 -- Simple case of a nondispatching trigger. Skip assignments to 12845 -- temporaries created for in-out parameters. 12846 12847 -- This makes unwarranted assumptions about the shape of the expanded 12848 -- tree for the call, and should be cleaned up ??? 12849 12850 Stmt := First (Stmts); 12851 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 12852 Next (Stmt); 12853 end loop; 12854 12855 -- Do the assignment at this stage only because the evaluation 12856 -- of the expression must not occur earlier (see ACVC C97302A). 12857 12858 Insert_Before (Stmt, 12859 Make_Assignment_Statement (Loc, 12860 Name => New_Occurrence_Of (D, Loc), 12861 Expression => D_Conv)); 12862 12863 Call := Stmt; 12864 Params := Parameter_Associations (Call); 12865 12866 -- For a protected type, we build a Timed_Protected_Entry_Call 12867 12868 if Is_Protected_Type (Etype (Concval)) then 12869 12870 -- Create a new call statement 12871 12872 Param := First (Params); 12873 while Present (Param) 12874 and then not Is_RTE (Etype (Param), RE_Call_Modes) 12875 loop 12876 Next (Param); 12877 end loop; 12878 12879 Dummy := Remove_Next (Next (Param)); 12880 12881 -- Remove garbage is following the Cancel_Param if present 12882 12883 Dummy := Next (Param); 12884 12885 -- Remove the mode of the Protected_Entry_Call call, then remove 12886 -- the Communication_Block of the Protected_Entry_Call call, and 12887 -- finally add Duration and a Delay_Mode parameter 12888 12889 pragma Assert (Present (Param)); 12890 Rewrite (Param, New_Occurrence_Of (D, Loc)); 12891 12892 Rewrite (Dummy, New_Occurrence_Of (M, Loc)); 12893 12894 -- Add a Boolean flag for successful entry call 12895 12896 Append_To (Params, New_Occurrence_Of (B, Loc)); 12897 12898 case Corresponding_Runtime_Package (Etype (Concval)) is 12899 when System_Tasking_Protected_Objects_Entries => 12900 Rewrite (Call, 12901 Make_Procedure_Call_Statement (Loc, 12902 Name => 12903 New_Occurrence_Of 12904 (RTE (RE_Timed_Protected_Entry_Call), Loc), 12905 Parameter_Associations => Params)); 12906 12907 when others => 12908 raise Program_Error; 12909 end case; 12910 12911 -- For the task case, build a Timed_Task_Entry_Call 12912 12913 else 12914 -- Create a new call statement 12915 12916 Append_To (Params, New_Occurrence_Of (D, Loc)); 12917 Append_To (Params, New_Occurrence_Of (M, Loc)); 12918 Append_To (Params, New_Occurrence_Of (B, Loc)); 12919 12920 Rewrite (Call, 12921 Make_Procedure_Call_Statement (Loc, 12922 Name => 12923 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc), 12924 Parameter_Associations => Params)); 12925 end if; 12926 12927 Append_To (Stmts, 12928 Make_Implicit_If_Statement (N, 12929 Condition => New_Occurrence_Of (B, Loc), 12930 Then_Statements => E_Stats, 12931 Else_Statements => D_Stats)); 12932 end if; 12933 12934 Rewrite (N, 12935 Make_Block_Statement (Loc, 12936 Declarations => Decls, 12937 Handled_Statement_Sequence => 12938 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 12939 12940 Analyze (N); 12941 12942 -- Some items in Decls used to be in the N_Block in E_Call that 12943 -- is constructed in Expand_Entry_Call, and are now in the new 12944 -- Block into which N has been rewritten. Adjust their scopes 12945 -- to reflect that. 12946 12947 if Nkind (E_Call) = N_Block_Statement then 12948 Obj := First_Entity (Entity (Identifier (E_Call))); 12949 while Present (Obj) loop 12950 Set_Scope (Obj, Entity (Identifier (N))); 12951 Next_Entity (Obj); 12952 end loop; 12953 end if; 12954 12955 Reset_Scopes_To (N, Entity (Identifier (N))); 12956 end Expand_N_Timed_Entry_Call; 12957 12958 ---------------------------------------- 12959 -- Expand_Protected_Body_Declarations -- 12960 ---------------------------------------- 12961 12962 procedure Expand_Protected_Body_Declarations 12963 (N : Node_Id; 12964 Spec_Id : Entity_Id) 12965 is 12966 begin 12967 if No_Run_Time_Mode then 12968 Error_Msg_CRT ("protected body", N); 12969 return; 12970 12971 elsif Expander_Active then 12972 12973 -- Associate discriminals with the first subprogram or entry body to 12974 -- be expanded. 12975 12976 if Present (First_Protected_Operation (Declarations (N))) then 12977 Set_Discriminals (Parent (Spec_Id)); 12978 end if; 12979 end if; 12980 end Expand_Protected_Body_Declarations; 12981 12982 ------------------------- 12983 -- External_Subprogram -- 12984 ------------------------- 12985 12986 function External_Subprogram (E : Entity_Id) return Entity_Id is 12987 Subp : constant Entity_Id := Protected_Body_Subprogram (E); 12988 12989 begin 12990 -- The internal and external subprograms follow each other on the entity 12991 -- chain. Note that previously private operations had no separate 12992 -- external subprogram. We now create one in all cases, because a 12993 -- private operation may actually appear in an external call, through 12994 -- a 'Access reference used for a callback. 12995 12996 -- If the operation is a function that returns an anonymous access type, 12997 -- the corresponding itype appears before the operation, and must be 12998 -- skipped. 12999 13000 -- This mechanism is fragile, there should be a real link between the 13001 -- two versions of the operation, but there is no place to put it ??? 13002 13003 if Is_Access_Type (Next_Entity (Subp)) then 13004 return Next_Entity (Next_Entity (Subp)); 13005 else 13006 return Next_Entity (Subp); 13007 end if; 13008 end External_Subprogram; 13009 13010 ------------------------------ 13011 -- Extract_Dispatching_Call -- 13012 ------------------------------ 13013 13014 procedure Extract_Dispatching_Call 13015 (N : Node_Id; 13016 Call_Ent : out Entity_Id; 13017 Object : out Entity_Id; 13018 Actuals : out List_Id; 13019 Formals : out List_Id) 13020 is 13021 Call_Nam : Node_Id; 13022 13023 begin 13024 pragma Assert (Nkind (N) = N_Procedure_Call_Statement); 13025 13026 if Present (Original_Node (N)) then 13027 Call_Nam := Name (Original_Node (N)); 13028 else 13029 Call_Nam := Name (N); 13030 end if; 13031 13032 -- Retrieve the name of the dispatching procedure. It contains the 13033 -- dispatch table slot number. 13034 13035 loop 13036 case Nkind (Call_Nam) is 13037 when N_Identifier => 13038 exit; 13039 13040 when N_Selected_Component => 13041 Call_Nam := Selector_Name (Call_Nam); 13042 13043 when others => 13044 raise Program_Error; 13045 end case; 13046 end loop; 13047 13048 Actuals := Parameter_Associations (N); 13049 Call_Ent := Entity (Call_Nam); 13050 Formals := Parameter_Specifications (Parent (Call_Ent)); 13051 Object := First (Actuals); 13052 13053 if Present (Original_Node (Object)) then 13054 Object := Original_Node (Object); 13055 end if; 13056 13057 -- If the type of the dispatching object is an access type then return 13058 -- an explicit dereference of a copy of the object, and note that this 13059 -- is the controlling actual of the call. 13060 13061 if Is_Access_Type (Etype (Object)) then 13062 Object := 13063 Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object)); 13064 Analyze (Object); 13065 Set_Is_Controlling_Actual (Object); 13066 end if; 13067 end Extract_Dispatching_Call; 13068 13069 ------------------- 13070 -- Extract_Entry -- 13071 ------------------- 13072 13073 procedure Extract_Entry 13074 (N : Node_Id; 13075 Concval : out Node_Id; 13076 Ename : out Node_Id; 13077 Index : out Node_Id) 13078 is 13079 Nam : constant Node_Id := Name (N); 13080 13081 begin 13082 -- For a simple entry, the name is a selected component, with the 13083 -- prefix being the task value, and the selector being the entry. 13084 13085 if Nkind (Nam) = N_Selected_Component then 13086 Concval := Prefix (Nam); 13087 Ename := Selector_Name (Nam); 13088 Index := Empty; 13089 13090 -- For a member of an entry family, the name is an indexed component 13091 -- where the prefix is a selected component, whose prefix in turn is 13092 -- the task value, and whose selector is the entry family. The single 13093 -- expression in the expressions list of the indexed component is the 13094 -- subscript for the family. 13095 13096 else pragma Assert (Nkind (Nam) = N_Indexed_Component); 13097 Concval := Prefix (Prefix (Nam)); 13098 Ename := Selector_Name (Prefix (Nam)); 13099 Index := First (Expressions (Nam)); 13100 end if; 13101 13102 -- Through indirection, the type may actually be a limited view of a 13103 -- concurrent type. When compiling a call, the non-limited view of the 13104 -- type is visible. 13105 13106 if From_Limited_With (Etype (Concval)) then 13107 Set_Etype (Concval, Non_Limited_View (Etype (Concval))); 13108 end if; 13109 end Extract_Entry; 13110 13111 ------------------- 13112 -- Family_Offset -- 13113 ------------------- 13114 13115 function Family_Offset 13116 (Loc : Source_Ptr; 13117 Hi : Node_Id; 13118 Lo : Node_Id; 13119 Ttyp : Entity_Id; 13120 Cap : Boolean) return Node_Id 13121 is 13122 Ityp : Entity_Id; 13123 Real_Hi : Node_Id; 13124 Real_Lo : Node_Id; 13125 13126 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 13127 -- If one of the bounds is a reference to a discriminant, replace with 13128 -- corresponding discriminal of type. Within the body of a task retrieve 13129 -- the renamed discriminant by simple visibility, using its generated 13130 -- name. Within a protected object, find the original discriminant and 13131 -- replace it with the discriminal of the current protected operation. 13132 13133 ------------------------------ 13134 -- Convert_Discriminant_Ref -- 13135 ------------------------------ 13136 13137 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 13138 Loc : constant Source_Ptr := Sloc (Bound); 13139 B : Node_Id; 13140 D : Entity_Id; 13141 13142 begin 13143 if Is_Entity_Name (Bound) 13144 and then Ekind (Entity (Bound)) = E_Discriminant 13145 then 13146 if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then 13147 B := Make_Identifier (Loc, Chars (Entity (Bound))); 13148 Find_Direct_Name (B); 13149 13150 elsif Is_Protected_Type (Ttyp) then 13151 D := First_Discriminant (Ttyp); 13152 while Chars (D) /= Chars (Entity (Bound)) loop 13153 Next_Discriminant (D); 13154 end loop; 13155 13156 B := New_Occurrence_Of (Discriminal (D), Loc); 13157 13158 else 13159 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); 13160 end if; 13161 13162 elsif Nkind (Bound) = N_Attribute_Reference then 13163 return Bound; 13164 13165 else 13166 B := New_Copy_Tree (Bound); 13167 end if; 13168 13169 return 13170 Make_Attribute_Reference (Loc, 13171 Attribute_Name => Name_Pos, 13172 Prefix => New_Occurrence_Of (Etype (Bound), Loc), 13173 Expressions => New_List (B)); 13174 end Convert_Discriminant_Ref; 13175 13176 -- Start of processing for Family_Offset 13177 13178 begin 13179 Real_Hi := Convert_Discriminant_Ref (Hi); 13180 Real_Lo := Convert_Discriminant_Ref (Lo); 13181 13182 if Cap then 13183 if Is_Task_Type (Ttyp) then 13184 Ityp := RTE (RE_Task_Entry_Index); 13185 else 13186 Ityp := RTE (RE_Protected_Entry_Index); 13187 end if; 13188 13189 Real_Hi := 13190 Make_Attribute_Reference (Loc, 13191 Prefix => New_Occurrence_Of (Ityp, Loc), 13192 Attribute_Name => Name_Min, 13193 Expressions => New_List ( 13194 Real_Hi, 13195 Make_Integer_Literal (Loc, Entry_Family_Bound - 1))); 13196 13197 Real_Lo := 13198 Make_Attribute_Reference (Loc, 13199 Prefix => New_Occurrence_Of (Ityp, Loc), 13200 Attribute_Name => Name_Max, 13201 Expressions => New_List ( 13202 Real_Lo, 13203 Make_Integer_Literal (Loc, -Entry_Family_Bound))); 13204 end if; 13205 13206 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo); 13207 end Family_Offset; 13208 13209 ----------------- 13210 -- Family_Size -- 13211 ----------------- 13212 13213 function Family_Size 13214 (Loc : Source_Ptr; 13215 Hi : Node_Id; 13216 Lo : Node_Id; 13217 Ttyp : Entity_Id; 13218 Cap : Boolean) return Node_Id 13219 is 13220 Ityp : Entity_Id; 13221 13222 begin 13223 if Is_Task_Type (Ttyp) then 13224 Ityp := RTE (RE_Task_Entry_Index); 13225 else 13226 Ityp := RTE (RE_Protected_Entry_Index); 13227 end if; 13228 13229 return 13230 Make_Attribute_Reference (Loc, 13231 Prefix => New_Occurrence_Of (Ityp, Loc), 13232 Attribute_Name => Name_Max, 13233 Expressions => New_List ( 13234 Make_Op_Add (Loc, 13235 Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap), 13236 Right_Opnd => Make_Integer_Literal (Loc, 1)), 13237 Make_Integer_Literal (Loc, 0))); 13238 end Family_Size; 13239 13240 ---------------------------- 13241 -- Find_Enclosing_Context -- 13242 ---------------------------- 13243 13244 procedure Find_Enclosing_Context 13245 (N : Node_Id; 13246 Context : out Node_Id; 13247 Context_Id : out Entity_Id; 13248 Context_Decls : out List_Id) 13249 is 13250 begin 13251 -- Traverse the parent chain looking for an enclosing body, block, 13252 -- package or return statement. 13253 13254 Context := Parent (N); 13255 while Present (Context) loop 13256 if Nkind_In (Context, N_Entry_Body, 13257 N_Extended_Return_Statement, 13258 N_Package_Body, 13259 N_Package_Declaration, 13260 N_Subprogram_Body, 13261 N_Task_Body) 13262 then 13263 exit; 13264 13265 -- Do not consider block created to protect a list of statements with 13266 -- an Abort_Defer / Abort_Undefer_Direct pair. 13267 13268 elsif Nkind (Context) = N_Block_Statement 13269 and then not Is_Abort_Block (Context) 13270 then 13271 exit; 13272 end if; 13273 13274 Context := Parent (Context); 13275 end loop; 13276 13277 pragma Assert (Present (Context)); 13278 13279 -- Extract the constituents of the context 13280 13281 if Nkind (Context) = N_Extended_Return_Statement then 13282 Context_Decls := Return_Object_Declarations (Context); 13283 Context_Id := Return_Statement_Entity (Context); 13284 13285 -- Package declarations and bodies use a common library-level activation 13286 -- chain or task master, therefore return the package declaration as the 13287 -- proper carrier for the appropriate flag. 13288 13289 elsif Nkind (Context) = N_Package_Body then 13290 Context_Decls := Declarations (Context); 13291 Context_Id := Corresponding_Spec (Context); 13292 Context := Parent (Context_Id); 13293 13294 if Nkind (Context) = N_Defining_Program_Unit_Name then 13295 Context := Parent (Parent (Context)); 13296 else 13297 Context := Parent (Context); 13298 end if; 13299 13300 elsif Nkind (Context) = N_Package_Declaration then 13301 Context_Decls := Visible_Declarations (Specification (Context)); 13302 Context_Id := Defining_Unit_Name (Specification (Context)); 13303 13304 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13305 Context_Id := Defining_Identifier (Context_Id); 13306 end if; 13307 13308 else 13309 if Nkind (Context) = N_Block_Statement then 13310 Context_Id := Entity (Identifier (Context)); 13311 13312 elsif Nkind (Context) = N_Entry_Body then 13313 Context_Id := Defining_Identifier (Context); 13314 13315 elsif Nkind (Context) = N_Subprogram_Body then 13316 if Present (Corresponding_Spec (Context)) then 13317 Context_Id := Corresponding_Spec (Context); 13318 else 13319 Context_Id := Defining_Unit_Name (Specification (Context)); 13320 13321 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13322 Context_Id := Defining_Identifier (Context_Id); 13323 end if; 13324 end if; 13325 13326 elsif Nkind (Context) = N_Task_Body then 13327 Context_Id := Corresponding_Spec (Context); 13328 13329 else 13330 raise Program_Error; 13331 end if; 13332 13333 Context_Decls := Declarations (Context); 13334 end if; 13335 13336 pragma Assert (Present (Context_Id)); 13337 pragma Assert (Present (Context_Decls)); 13338 end Find_Enclosing_Context; 13339 13340 ----------------------- 13341 -- Find_Master_Scope -- 13342 ----------------------- 13343 13344 function Find_Master_Scope (E : Entity_Id) return Entity_Id is 13345 S : Entity_Id; 13346 13347 begin 13348 -- In Ada 2005, the master is the innermost enclosing scope that is not 13349 -- transient. If the enclosing block is the rewriting of a call or the 13350 -- scope is an extended return statement this is valid master. The 13351 -- master in an extended return is only used within the return, and is 13352 -- subsequently overwritten in Move_Activation_Chain, but it must exist 13353 -- now before that overwriting occurs. 13354 13355 S := Scope (E); 13356 13357 if Ada_Version >= Ada_2005 then 13358 while Is_Internal (S) loop 13359 if Nkind (Parent (S)) = N_Block_Statement 13360 and then 13361 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement 13362 then 13363 exit; 13364 13365 elsif Ekind (S) = E_Return_Statement then 13366 exit; 13367 13368 else 13369 S := Scope (S); 13370 end if; 13371 end loop; 13372 end if; 13373 13374 return S; 13375 end Find_Master_Scope; 13376 13377 ------------------------------- 13378 -- First_Protected_Operation -- 13379 ------------------------------- 13380 13381 function First_Protected_Operation (D : List_Id) return Node_Id is 13382 First_Op : Node_Id; 13383 13384 begin 13385 First_Op := First (D); 13386 while Present (First_Op) 13387 and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body) 13388 loop 13389 Next (First_Op); 13390 end loop; 13391 13392 return First_Op; 13393 end First_Protected_Operation; 13394 13395 --------------------------------------- 13396 -- Install_Private_Data_Declarations -- 13397 --------------------------------------- 13398 13399 procedure Install_Private_Data_Declarations 13400 (Loc : Source_Ptr; 13401 Spec_Id : Entity_Id; 13402 Conc_Typ : Entity_Id; 13403 Body_Nod : Node_Id; 13404 Decls : List_Id; 13405 Barrier : Boolean := False; 13406 Family : Boolean := False) 13407 is 13408 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ); 13409 Decl : Node_Id; 13410 Def : Node_Id; 13411 Insert_Node : Node_Id := Empty; 13412 Obj_Ent : Entity_Id; 13413 13414 procedure Add (Decl : Node_Id); 13415 -- Add a single declaration after Insert_Node. If this is the first 13416 -- addition, Decl is added to the front of Decls and it becomes the 13417 -- insertion node. 13418 13419 function Replace_Bound (Bound : Node_Id) return Node_Id; 13420 -- The bounds of an entry index may depend on discriminants, create a 13421 -- reference to the corresponding prival. Otherwise return a duplicate 13422 -- of the original bound. 13423 13424 --------- 13425 -- Add -- 13426 --------- 13427 13428 procedure Add (Decl : Node_Id) is 13429 begin 13430 if No (Insert_Node) then 13431 Prepend_To (Decls, Decl); 13432 else 13433 Insert_After (Insert_Node, Decl); 13434 end if; 13435 13436 Insert_Node := Decl; 13437 end Add; 13438 13439 ------------------- 13440 -- Replace_Bound -- 13441 ------------------- 13442 13443 function Replace_Bound (Bound : Node_Id) return Node_Id is 13444 begin 13445 if Nkind (Bound) = N_Identifier 13446 and then Is_Discriminal (Entity (Bound)) 13447 then 13448 return Make_Identifier (Loc, Chars (Entity (Bound))); 13449 else 13450 return Duplicate_Subexpr (Bound); 13451 end if; 13452 end Replace_Bound; 13453 13454 -- Start of processing for Install_Private_Data_Declarations 13455 13456 begin 13457 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote 13458 -- formal parameter _O, _object or _task depending on the context. 13459 13460 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ); 13461 13462 -- Special processing of _O for barrier functions, protected entries 13463 -- and families. 13464 13465 if Barrier 13466 or else 13467 (Is_Protected 13468 and then 13469 (Ekind (Spec_Id) = E_Entry 13470 or else Ekind (Spec_Id) = E_Entry_Family)) 13471 then 13472 declare 13473 Conc_Rec : constant Entity_Id := 13474 Corresponding_Record_Type (Conc_Typ); 13475 Typ_Id : constant Entity_Id := 13476 Make_Defining_Identifier (Loc, 13477 New_External_Name (Chars (Conc_Rec), 'P')); 13478 begin 13479 -- Generate: 13480 -- type prot_typVP is access prot_typV; 13481 13482 Decl := 13483 Make_Full_Type_Declaration (Loc, 13484 Defining_Identifier => Typ_Id, 13485 Type_Definition => 13486 Make_Access_To_Object_Definition (Loc, 13487 Subtype_Indication => 13488 New_Occurrence_Of (Conc_Rec, Loc))); 13489 Add (Decl); 13490 13491 -- Generate: 13492 -- _object : prot_typVP := prot_typV (_O); 13493 13494 Decl := 13495 Make_Object_Declaration (Loc, 13496 Defining_Identifier => 13497 Make_Defining_Identifier (Loc, Name_uObject), 13498 Object_Definition => New_Occurrence_Of (Typ_Id, Loc), 13499 Expression => 13500 Unchecked_Convert_To (Typ_Id, 13501 New_Occurrence_Of (Obj_Ent, Loc))); 13502 Add (Decl); 13503 13504 -- Set the reference to the concurrent object 13505 13506 Obj_Ent := Defining_Identifier (Decl); 13507 end; 13508 end if; 13509 13510 -- Step 2: Create the Protection object and build its declaration for 13511 -- any protected entry (family) of subprogram. Note for the lock-free 13512 -- implementation, the Protection object is not needed anymore. 13513 13514 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then 13515 declare 13516 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); 13517 Prot_Typ : RE_Id; 13518 13519 begin 13520 Set_Protection_Object (Spec_Id, Prot_Ent); 13521 13522 -- Determine the proper protection type 13523 13524 if Has_Attach_Handler (Conc_Typ) 13525 and then not Restricted_Profile 13526 then 13527 Prot_Typ := RE_Static_Interrupt_Protection; 13528 13529 elsif Has_Interrupt_Handler (Conc_Typ) 13530 and then not Restriction_Active (No_Dynamic_Attachment) 13531 then 13532 Prot_Typ := RE_Dynamic_Interrupt_Protection; 13533 13534 else 13535 case Corresponding_Runtime_Package (Conc_Typ) is 13536 when System_Tasking_Protected_Objects_Entries => 13537 Prot_Typ := RE_Protection_Entries; 13538 13539 when System_Tasking_Protected_Objects_Single_Entry => 13540 Prot_Typ := RE_Protection_Entry; 13541 13542 when System_Tasking_Protected_Objects => 13543 Prot_Typ := RE_Protection; 13544 13545 when others => 13546 raise Program_Error; 13547 end case; 13548 end if; 13549 13550 -- Generate: 13551 -- conc_typR : protection_typ renames _object._object; 13552 13553 Decl := 13554 Make_Object_Renaming_Declaration (Loc, 13555 Defining_Identifier => Prot_Ent, 13556 Subtype_Mark => 13557 New_Occurrence_Of (RTE (Prot_Typ), Loc), 13558 Name => 13559 Make_Selected_Component (Loc, 13560 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13561 Selector_Name => Make_Identifier (Loc, Name_uObject))); 13562 Add (Decl); 13563 end; 13564 end if; 13565 13566 -- Step 3: Add discriminant renamings (if any) 13567 13568 if Has_Discriminants (Conc_Typ) then 13569 declare 13570 D : Entity_Id; 13571 13572 begin 13573 D := First_Discriminant (Conc_Typ); 13574 while Present (D) loop 13575 13576 -- Adjust the source location 13577 13578 Set_Sloc (Discriminal (D), Loc); 13579 13580 -- Generate: 13581 -- discr_name : discr_typ renames _object.discr_name; 13582 -- or 13583 -- discr_name : discr_typ renames _task.discr_name; 13584 13585 Decl := 13586 Make_Object_Renaming_Declaration (Loc, 13587 Defining_Identifier => Discriminal (D), 13588 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc), 13589 Name => 13590 Make_Selected_Component (Loc, 13591 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13592 Selector_Name => Make_Identifier (Loc, Chars (D)))); 13593 Add (Decl); 13594 13595 -- Set debug info needed on this renaming declaration even 13596 -- though it does not come from source, so that the debugger 13597 -- will get the right information for these generated names. 13598 13599 Set_Debug_Info_Needed (Discriminal (D)); 13600 13601 Next_Discriminant (D); 13602 end loop; 13603 end; 13604 end if; 13605 13606 -- Step 4: Add private component renamings (if any) 13607 13608 if Is_Protected then 13609 Def := Protected_Definition (Parent (Conc_Typ)); 13610 13611 if Present (Private_Declarations (Def)) then 13612 declare 13613 Comp : Node_Id; 13614 Comp_Id : Entity_Id; 13615 Decl_Id : Entity_Id; 13616 13617 begin 13618 Comp := First (Private_Declarations (Def)); 13619 while Present (Comp) loop 13620 if Nkind (Comp) = N_Component_Declaration then 13621 Comp_Id := Defining_Identifier (Comp); 13622 Decl_Id := 13623 Make_Defining_Identifier (Loc, Chars (Comp_Id)); 13624 13625 -- Minimal decoration 13626 13627 if Ekind (Spec_Id) = E_Function then 13628 Set_Ekind (Decl_Id, E_Constant); 13629 else 13630 Set_Ekind (Decl_Id, E_Variable); 13631 end if; 13632 13633 Set_Prival (Comp_Id, Decl_Id); 13634 Set_Prival_Link (Decl_Id, Comp_Id); 13635 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); 13636 13637 -- Generate: 13638 -- comp_name : comp_typ renames _object.comp_name; 13639 13640 Decl := 13641 Make_Object_Renaming_Declaration (Loc, 13642 Defining_Identifier => Decl_Id, 13643 Subtype_Mark => 13644 New_Occurrence_Of (Etype (Comp_Id), Loc), 13645 Name => 13646 Make_Selected_Component (Loc, 13647 Prefix => 13648 New_Occurrence_Of (Obj_Ent, Loc), 13649 Selector_Name => 13650 Make_Identifier (Loc, Chars (Comp_Id)))); 13651 Add (Decl); 13652 end if; 13653 13654 Next (Comp); 13655 end loop; 13656 end; 13657 end if; 13658 end if; 13659 13660 -- Step 5: Add the declaration of the entry index and the associated 13661 -- type for barrier functions and entry families. 13662 13663 if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then 13664 declare 13665 E : constant Entity_Id := Index_Object (Spec_Id); 13666 Index : constant Entity_Id := 13667 Defining_Identifier 13668 (Entry_Index_Specification 13669 (Entry_Body_Formal_Part (Body_Nod))); 13670 Index_Con : constant Entity_Id := 13671 Make_Defining_Identifier (Loc, Chars (Index)); 13672 High : Node_Id; 13673 Index_Typ : Entity_Id; 13674 Low : Node_Id; 13675 13676 begin 13677 -- Minimal decoration 13678 13679 Set_Ekind (Index_Con, E_Constant); 13680 Set_Entry_Index_Constant (Index, Index_Con); 13681 Set_Discriminal_Link (Index_Con, Index); 13682 13683 -- Retrieve the bounds of the entry family 13684 13685 High := Type_High_Bound (Etype (Index)); 13686 Low := Type_Low_Bound (Etype (Index)); 13687 13688 -- In the simple case the entry family is given by a subtype mark 13689 -- and the index constant has the same type. 13690 13691 if Is_Entity_Name (Original_Node ( 13692 Discrete_Subtype_Definition (Parent (Index)))) 13693 then 13694 Index_Typ := Etype (Index); 13695 13696 -- Otherwise a new subtype declaration is required 13697 13698 else 13699 High := Replace_Bound (High); 13700 Low := Replace_Bound (Low); 13701 13702 Index_Typ := Make_Temporary (Loc, 'J'); 13703 13704 -- Generate: 13705 -- subtype Jnn is <Etype of Index> range Low .. High; 13706 13707 Decl := 13708 Make_Subtype_Declaration (Loc, 13709 Defining_Identifier => Index_Typ, 13710 Subtype_Indication => 13711 Make_Subtype_Indication (Loc, 13712 Subtype_Mark => 13713 New_Occurrence_Of (Base_Type (Etype (Index)), Loc), 13714 Constraint => 13715 Make_Range_Constraint (Loc, 13716 Range_Expression => 13717 Make_Range (Loc, Low, High)))); 13718 Add (Decl); 13719 end if; 13720 13721 Set_Etype (Index_Con, Index_Typ); 13722 13723 -- Create the object which designates the index: 13724 -- J : constant Jnn := 13725 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First)); 13726 -- 13727 -- where Jnn is the subtype created above or the original type of 13728 -- the index, _E is a formal of the protected body subprogram and 13729 -- <index expr> is the index of the first family member. 13730 13731 Decl := 13732 Make_Object_Declaration (Loc, 13733 Defining_Identifier => Index_Con, 13734 Constant_Present => True, 13735 Object_Definition => 13736 New_Occurrence_Of (Index_Typ, Loc), 13737 13738 Expression => 13739 Make_Attribute_Reference (Loc, 13740 Prefix => 13741 New_Occurrence_Of (Index_Typ, Loc), 13742 Attribute_Name => Name_Val, 13743 13744 Expressions => New_List ( 13745 13746 Make_Op_Add (Loc, 13747 Left_Opnd => 13748 Make_Op_Subtract (Loc, 13749 Left_Opnd => New_Occurrence_Of (E, Loc), 13750 Right_Opnd => 13751 Entry_Index_Expression (Loc, 13752 Defining_Identifier (Body_Nod), 13753 Empty, Conc_Typ)), 13754 13755 Right_Opnd => 13756 Make_Attribute_Reference (Loc, 13757 Prefix => 13758 New_Occurrence_Of (Index_Typ, Loc), 13759 Attribute_Name => Name_Pos, 13760 Expressions => New_List ( 13761 Make_Attribute_Reference (Loc, 13762 Prefix => 13763 New_Occurrence_Of (Index_Typ, Loc), 13764 Attribute_Name => Name_First))))))); 13765 Add (Decl); 13766 end; 13767 end if; 13768 end Install_Private_Data_Declarations; 13769 13770 --------------------------------- 13771 -- Is_Potentially_Large_Family -- 13772 --------------------------------- 13773 13774 function Is_Potentially_Large_Family 13775 (Base_Index : Entity_Id; 13776 Conctyp : Entity_Id; 13777 Lo : Node_Id; 13778 Hi : Node_Id) return Boolean 13779 is 13780 begin 13781 return Scope (Base_Index) = Standard_Standard 13782 and then Base_Index = Base_Type (Standard_Integer) 13783 and then Has_Discriminants (Conctyp) 13784 and then 13785 Present (Discriminant_Default_Value (First_Discriminant (Conctyp))) 13786 and then 13787 (Denotes_Discriminant (Lo, True) 13788 or else 13789 Denotes_Discriminant (Hi, True)); 13790 end Is_Potentially_Large_Family; 13791 13792 ------------------------------------- 13793 -- Is_Private_Primitive_Subprogram -- 13794 ------------------------------------- 13795 13796 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is 13797 begin 13798 return 13799 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure) 13800 and then Is_Private_Primitive (Id); 13801 end Is_Private_Primitive_Subprogram; 13802 13803 ------------------ 13804 -- Index_Object -- 13805 ------------------ 13806 13807 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is 13808 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id); 13809 Formal : Entity_Id; 13810 13811 begin 13812 Formal := First_Formal (Bod_Subp); 13813 while Present (Formal) loop 13814 13815 -- Look for formal parameter _E 13816 13817 if Chars (Formal) = Name_uE then 13818 return Formal; 13819 end if; 13820 13821 Next_Formal (Formal); 13822 end loop; 13823 13824 -- A protected body subprogram should always have the parameter in 13825 -- question. 13826 13827 raise Program_Error; 13828 end Index_Object; 13829 13830 -------------------------------- 13831 -- Make_Initialize_Protection -- 13832 -------------------------------- 13833 13834 function Make_Initialize_Protection 13835 (Protect_Rec : Entity_Id) return List_Id 13836 is 13837 Loc : constant Source_Ptr := Sloc (Protect_Rec); 13838 P_Arr : Entity_Id; 13839 Pdec : Node_Id; 13840 Ptyp : constant Node_Id := 13841 Corresponding_Concurrent_Type (Protect_Rec); 13842 Args : List_Id; 13843 L : constant List_Id := New_List; 13844 Has_Entry : constant Boolean := Has_Entries (Ptyp); 13845 Prio_Type : Entity_Id; 13846 Prio_Var : Entity_Id := Empty; 13847 Restricted : constant Boolean := Restricted_Profile; 13848 13849 begin 13850 -- We may need two calls to properly initialize the object, one to 13851 -- Initialize_Protection, and possibly one to Install_Handlers if we 13852 -- have a pragma Attach_Handler. 13853 13854 -- Get protected declaration. In the case of a task type declaration, 13855 -- this is simply the parent of the protected type entity. In the single 13856 -- protected object declaration, this parent will be the implicit type, 13857 -- and we can find the corresponding single protected object declaration 13858 -- by searching forward in the declaration list in the tree. 13859 13860 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes 13861 -- of this type should have been removed during semantic analysis. 13862 13863 Pdec := Parent (Ptyp); 13864 while not Nkind_In (Pdec, N_Protected_Type_Declaration, 13865 N_Single_Protected_Declaration) 13866 loop 13867 Next (Pdec); 13868 end loop; 13869 13870 -- Build the parameter list for the call. Note that _Init is the name 13871 -- of the formal for the object to be initialized, which is the task 13872 -- value record itself. 13873 13874 Args := New_List; 13875 13876 -- For lock-free implementation, skip initializations of the Protection 13877 -- object. 13878 13879 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 13880 13881 -- Object parameter. This is a pointer to the object of type 13882 -- Protection used by the GNARL to control the protected object. 13883 13884 Append_To (Args, 13885 Make_Attribute_Reference (Loc, 13886 Prefix => 13887 Make_Selected_Component (Loc, 13888 Prefix => Make_Identifier (Loc, Name_uInit), 13889 Selector_Name => Make_Identifier (Loc, Name_uObject)), 13890 Attribute_Name => Name_Unchecked_Access)); 13891 13892 -- Priority parameter. Set to Unspecified_Priority unless there is a 13893 -- Priority rep item, in which case we take the value from the pragma 13894 -- or attribute definition clause, or there is an Interrupt_Priority 13895 -- rep item and no Priority rep item, and we set the ceiling to 13896 -- Interrupt_Priority'Last, an implementation-defined value, see 13897 -- (RM D.3(10)). 13898 13899 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then 13900 declare 13901 Prio_Clause : constant Node_Id := 13902 Get_Rep_Item 13903 (Ptyp, Name_Priority, Check_Parents => False); 13904 13905 Prio : Node_Id; 13906 13907 begin 13908 -- Pragma Priority 13909 13910 if Nkind (Prio_Clause) = N_Pragma then 13911 Prio := 13912 Expression 13913 (First (Pragma_Argument_Associations (Prio_Clause))); 13914 13915 -- Get_Rep_Item returns either priority pragma 13916 13917 if Pragma_Name (Prio_Clause) = Name_Priority then 13918 Prio_Type := RTE (RE_Any_Priority); 13919 else 13920 Prio_Type := RTE (RE_Interrupt_Priority); 13921 end if; 13922 13923 -- Attribute definition clause Priority 13924 13925 else 13926 if Chars (Prio_Clause) = Name_Priority then 13927 Prio_Type := RTE (RE_Any_Priority); 13928 else 13929 Prio_Type := RTE (RE_Interrupt_Priority); 13930 end if; 13931 13932 Prio := Expression (Prio_Clause); 13933 end if; 13934 13935 -- Always create a locale variable to capture the priority. 13936 -- The priority is also passed to Install_Restriced_Handlers. 13937 -- Note that it is really necessary to create this variable 13938 -- explicitly. It might be thought that removing side effects 13939 -- would the appropriate approach, but that could generate 13940 -- declarations improperly placed in the enclosing scope. 13941 13942 Prio_Var := Make_Temporary (Loc, 'R', Prio); 13943 Append_To (L, 13944 Make_Object_Declaration (Loc, 13945 Defining_Identifier => Prio_Var, 13946 Object_Definition => New_Occurrence_Of (Prio_Type, Loc), 13947 Expression => Relocate_Node (Prio))); 13948 13949 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 13950 end; 13951 13952 -- When no priority is specified but an xx_Handler pragma is, we 13953 -- default to System.Interrupts.Default_Interrupt_Priority, see 13954 -- D.3(10). 13955 13956 elsif Has_Attach_Handler (Ptyp) 13957 or else Has_Interrupt_Handler (Ptyp) 13958 then 13959 Append_To (Args, 13960 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc)); 13961 13962 -- Normal case, no priority or xx_Handler specified, default priority 13963 13964 else 13965 Append_To (Args, 13966 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 13967 end if; 13968 13969 -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes 13970 13971 if Restricted_Profile and Task_Dispatching_Policy = 'E' then 13972 Deadline_Floor : declare 13973 Item : constant Node_Id := 13974 Get_Rep_Item 13975 (Ptyp, Name_Deadline_Floor, Check_Parents => False); 13976 13977 Deadline : Node_Id; 13978 13979 begin 13980 if Present (Item) then 13981 13982 -- Pragma Deadline_Floor 13983 13984 if Nkind (Item) = N_Pragma then 13985 Deadline := 13986 Expression 13987 (First (Pragma_Argument_Associations (Item))); 13988 13989 -- Attribute definition clause Deadline_Floor 13990 13991 else 13992 pragma Assert 13993 (Nkind (Item) = N_Attribute_Definition_Clause); 13994 13995 Deadline := Expression (Item); 13996 end if; 13997 13998 Append_To (Args, Deadline); 13999 14000 -- Unusual case: default deadline 14001 14002 else 14003 Append_To (Args, 14004 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 14005 end if; 14006 end Deadline_Floor; 14007 end if; 14008 14009 -- Test for Compiler_Info parameter. This parameter allows entry body 14010 -- procedures and barrier functions to be called from the runtime. It 14011 -- is a pointer to the record generated by the compiler to represent 14012 -- the protected object. 14013 14014 -- A protected type without entries that covers an interface and 14015 -- overrides the abstract routines with protected procedures is 14016 -- considered equivalent to a protected type with entries in the 14017 -- context of dispatching select statements. 14018 14019 -- Protected types with interrupt handlers (when not using a 14020 -- restricted profile) are also considered equivalent to protected 14021 -- types with entries. 14022 14023 -- The types which are used (Static_Interrupt_Protection and 14024 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries. 14025 14026 declare 14027 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); 14028 14029 Called_Subp : RE_Id; 14030 14031 begin 14032 case Pkg_Id is 14033 when System_Tasking_Protected_Objects_Entries => 14034 Called_Subp := RE_Initialize_Protection_Entries; 14035 14036 -- Argument Compiler_Info 14037 14038 Append_To (Args, 14039 Make_Attribute_Reference (Loc, 14040 Prefix => Make_Identifier (Loc, Name_uInit), 14041 Attribute_Name => Name_Address)); 14042 14043 when System_Tasking_Protected_Objects_Single_Entry => 14044 Called_Subp := RE_Initialize_Protection_Entry; 14045 14046 -- Argument Compiler_Info 14047 14048 Append_To (Args, 14049 Make_Attribute_Reference (Loc, 14050 Prefix => Make_Identifier (Loc, Name_uInit), 14051 Attribute_Name => Name_Address)); 14052 14053 when System_Tasking_Protected_Objects => 14054 Called_Subp := RE_Initialize_Protection; 14055 14056 when others => 14057 raise Program_Error; 14058 end case; 14059 14060 -- Entry_Queue_Maxes parameter. This is an access to an array of 14061 -- naturals representing the entry queue maximums for each entry 14062 -- in the protected type. Zero represents no max. The access is 14063 -- null if there is no limit for all entries (usual case). 14064 14065 if Has_Entry 14066 and then Pkg_Id = System_Tasking_Protected_Objects_Entries 14067 then 14068 if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then 14069 Append_To (Args, 14070 Make_Attribute_Reference (Loc, 14071 Prefix => 14072 New_Occurrence_Of 14073 (Entry_Max_Queue_Lengths_Array (Ptyp), Loc), 14074 Attribute_Name => Name_Unrestricted_Access)); 14075 else 14076 Append_To (Args, Make_Null (Loc)); 14077 end if; 14078 14079 -- Edge cases exist where entry initialization functions are 14080 -- called, but no entries exist, so null is appended. 14081 14082 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 14083 Append_To (Args, Make_Null (Loc)); 14084 end if; 14085 14086 -- Entry_Bodies parameter. This is a pointer to an array of 14087 -- pointers to the entry body procedures and barrier functions of 14088 -- the object. If the protected type has no entries this object 14089 -- will not exist, in this case, pass a null (it can happen when 14090 -- there are protected interrupt handlers or interfaces). 14091 14092 if Has_Entry then 14093 P_Arr := Entry_Bodies_Array (Ptyp); 14094 14095 -- Argument Entry_Body (for single entry) or Entry_Bodies (for 14096 -- multiple entries). 14097 14098 Append_To (Args, 14099 Make_Attribute_Reference (Loc, 14100 Prefix => New_Occurrence_Of (P_Arr, Loc), 14101 Attribute_Name => Name_Unrestricted_Access)); 14102 14103 if Pkg_Id = System_Tasking_Protected_Objects_Entries then 14104 14105 -- Find index mapping function (clumsy but ok for now) 14106 14107 while Ekind (P_Arr) /= E_Function loop 14108 Next_Entity (P_Arr); 14109 end loop; 14110 14111 Append_To (Args, 14112 Make_Attribute_Reference (Loc, 14113 Prefix => New_Occurrence_Of (P_Arr, Loc), 14114 Attribute_Name => Name_Unrestricted_Access)); 14115 end if; 14116 14117 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then 14118 14119 -- This is the case where we have a protected object with 14120 -- interfaces and no entries, and the single entry restriction 14121 -- is in effect. We pass a null pointer for the entry 14122 -- parameter because there is no actual entry. 14123 14124 Append_To (Args, Make_Null (Loc)); 14125 14126 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 14127 14128 -- This is the case where we have a protected object with no 14129 -- entries and: 14130 -- - either interrupt handlers with non restricted profile, 14131 -- - or interfaces 14132 -- Note that the types which are used for interrupt handlers 14133 -- (Static/Dynamic_Interrupt_Protection) are derived from 14134 -- Protection_Entries. We pass two null pointers because there 14135 -- is no actual entry, and the initialization procedure needs 14136 -- both Entry_Bodies and Find_Body_Index. 14137 14138 Append_To (Args, Make_Null (Loc)); 14139 Append_To (Args, Make_Null (Loc)); 14140 end if; 14141 14142 Append_To (L, 14143 Make_Procedure_Call_Statement (Loc, 14144 Name => 14145 New_Occurrence_Of (RTE (Called_Subp), Loc), 14146 Parameter_Associations => Args)); 14147 end; 14148 end if; 14149 14150 if Has_Attach_Handler (Ptyp) then 14151 14152 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to 14153 -- make the following call: 14154 14155 -- Install_Handlers (_object, 14156 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 14157 14158 -- or, in the case of Ravenscar: 14159 14160 -- Install_Restricted_Handlers 14161 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access))); 14162 14163 declare 14164 Args : constant List_Id := New_List; 14165 Table : constant List_Id := New_List; 14166 Ritem : Node_Id := First_Rep_Item (Ptyp); 14167 14168 begin 14169 -- Build the Priority parameter (only for ravenscar) 14170 14171 if Restricted then 14172 14173 -- Priority comes from a pragma 14174 14175 if Present (Prio_Var) then 14176 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 14177 14178 -- Priority is the default one 14179 14180 else 14181 Append_To (Args, 14182 New_Occurrence_Of 14183 (RTE (RE_Default_Interrupt_Priority), Loc)); 14184 end if; 14185 end if; 14186 14187 -- Build the Attach_Handler table argument 14188 14189 while Present (Ritem) loop 14190 if Nkind (Ritem) = N_Pragma 14191 and then Pragma_Name (Ritem) = Name_Attach_Handler 14192 then 14193 declare 14194 Handler : constant Node_Id := 14195 First (Pragma_Argument_Associations (Ritem)); 14196 14197 Interrupt : constant Node_Id := Next (Handler); 14198 Expr : constant Node_Id := Expression (Interrupt); 14199 14200 begin 14201 Append_To (Table, 14202 Make_Aggregate (Loc, Expressions => New_List ( 14203 Unchecked_Convert_To 14204 (RTE (RE_System_Interrupt_Id), Expr), 14205 Make_Attribute_Reference (Loc, 14206 Prefix => 14207 Make_Selected_Component (Loc, 14208 Prefix => 14209 Make_Identifier (Loc, Name_uInit), 14210 Selector_Name => 14211 Duplicate_Subexpr_No_Checks 14212 (Expression (Handler))), 14213 Attribute_Name => Name_Access)))); 14214 end; 14215 end if; 14216 14217 Next_Rep_Item (Ritem); 14218 end loop; 14219 14220 -- Append the table argument we just built 14221 14222 Append_To (Args, Make_Aggregate (Loc, Table)); 14223 14224 -- Append the Install_Handlers (or Install_Restricted_Handlers) 14225 -- call to the statements. 14226 14227 if Restricted then 14228 -- Call a simplified version of Install_Handlers to be used 14229 -- when the Ravenscar restrictions are in effect 14230 -- (Install_Restricted_Handlers). 14231 14232 Append_To (L, 14233 Make_Procedure_Call_Statement (Loc, 14234 Name => 14235 New_Occurrence_Of 14236 (RTE (RE_Install_Restricted_Handlers), Loc), 14237 Parameter_Associations => Args)); 14238 14239 else 14240 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 14241 14242 -- First, prepends the _object argument 14243 14244 Prepend_To (Args, 14245 Make_Attribute_Reference (Loc, 14246 Prefix => 14247 Make_Selected_Component (Loc, 14248 Prefix => Make_Identifier (Loc, Name_uInit), 14249 Selector_Name => 14250 Make_Identifier (Loc, Name_uObject)), 14251 Attribute_Name => Name_Unchecked_Access)); 14252 end if; 14253 14254 -- Then, insert call to Install_Handlers 14255 14256 Append_To (L, 14257 Make_Procedure_Call_Statement (Loc, 14258 Name => 14259 New_Occurrence_Of (RTE (RE_Install_Handlers), Loc), 14260 Parameter_Associations => Args)); 14261 end if; 14262 end; 14263 end if; 14264 14265 return L; 14266 end Make_Initialize_Protection; 14267 14268 --------------------------- 14269 -- Make_Task_Create_Call -- 14270 --------------------------- 14271 14272 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is 14273 Loc : constant Source_Ptr := Sloc (Task_Rec); 14274 Args : List_Id; 14275 Ecount : Node_Id; 14276 Name : Node_Id; 14277 Tdec : Node_Id; 14278 Tdef : Node_Id; 14279 Tnam : Name_Id; 14280 Ttyp : Node_Id; 14281 14282 begin 14283 Ttyp := Corresponding_Concurrent_Type (Task_Rec); 14284 Tnam := Chars (Ttyp); 14285 14286 -- Get task declaration. In the case of a task type declaration, this is 14287 -- simply the parent of the task type entity. In the single task 14288 -- declaration, this parent will be the implicit type, and we can find 14289 -- the corresponding single task declaration by searching forward in the 14290 -- declaration list in the tree. 14291 14292 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of 14293 -- this type should have been removed during semantic analysis. 14294 14295 Tdec := Parent (Ttyp); 14296 while not Nkind_In (Tdec, N_Task_Type_Declaration, 14297 N_Single_Task_Declaration) 14298 loop 14299 Next (Tdec); 14300 end loop; 14301 14302 -- Now we can find the task definition from this declaration 14303 14304 Tdef := Task_Definition (Tdec); 14305 14306 -- Build the parameter list for the call. Note that _Init is the name 14307 -- of the formal for the object to be initialized, which is the task 14308 -- value record itself. 14309 14310 Args := New_List; 14311 14312 -- Priority parameter. Set to Unspecified_Priority unless there is a 14313 -- Priority rep item, in which case we take the value from the rep item. 14314 -- Not used on Ravenscar_EDF profile. 14315 14316 if not (Restricted_Profile and then Task_Dispatching_Policy = 'E') then 14317 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then 14318 Append_To (Args, 14319 Make_Selected_Component (Loc, 14320 Prefix => Make_Identifier (Loc, Name_uInit), 14321 Selector_Name => Make_Identifier (Loc, Name_uPriority))); 14322 else 14323 Append_To (Args, 14324 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 14325 end if; 14326 end if; 14327 14328 -- Optional Stack parameter 14329 14330 if Restricted_Profile then 14331 14332 -- If the stack has been preallocated by the expander then 14333 -- pass its address. Otherwise, pass a null address. 14334 14335 if Preallocated_Stacks_On_Target then 14336 Append_To (Args, 14337 Make_Attribute_Reference (Loc, 14338 Prefix => 14339 Make_Selected_Component (Loc, 14340 Prefix => Make_Identifier (Loc, Name_uInit), 14341 Selector_Name => Make_Identifier (Loc, Name_uStack)), 14342 Attribute_Name => Name_Address)); 14343 14344 else 14345 Append_To (Args, 14346 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 14347 end if; 14348 end if; 14349 14350 -- Size parameter. If no Storage_Size pragma is present, then 14351 -- the size is taken from the taskZ variable for the type, which 14352 -- is either Unspecified_Size, or has been reset by the use of 14353 -- a Storage_Size attribute definition clause. If a pragma is 14354 -- present, then the size is taken from the _Size field of the 14355 -- task value record, which was set from the pragma value. 14356 14357 if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then 14358 Append_To (Args, 14359 Make_Selected_Component (Loc, 14360 Prefix => Make_Identifier (Loc, Name_uInit), 14361 Selector_Name => Make_Identifier (Loc, Name_uSize))); 14362 14363 else 14364 Append_To (Args, 14365 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc)); 14366 end if; 14367 14368 -- Secondary_Stack parameter used for restricted profiles 14369 14370 if Restricted_Profile then 14371 14372 -- If the secondary stack has been allocated by the expander then 14373 -- pass its access pointer. Otherwise, pass null. 14374 14375 if Create_Secondary_Stack_For_Task (Ttyp) then 14376 Append_To (Args, 14377 Make_Attribute_Reference (Loc, 14378 Prefix => 14379 Make_Selected_Component (Loc, 14380 Prefix => Make_Identifier (Loc, Name_uInit), 14381 Selector_Name => 14382 Make_Identifier (Loc, Name_uSecondary_Stack)), 14383 Attribute_Name => Name_Unrestricted_Access)); 14384 14385 else 14386 Append_To (Args, Make_Null (Loc)); 14387 end if; 14388 end if; 14389 14390 -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there 14391 -- is a Secondary_Stack_Size pragma, in which case take the value from 14392 -- the pragma. If the restriction No_Secondary_Stack is active then a 14393 -- size of 0 is passed regardless to prevent the allocation of the 14394 -- unused stack. 14395 14396 if Restriction_Active (No_Secondary_Stack) then 14397 Append_To (Args, Make_Integer_Literal (Loc, 0)); 14398 14399 elsif Has_Rep_Pragma 14400 (Ttyp, Name_Secondary_Stack_Size, Check_Parents => False) 14401 then 14402 Append_To (Args, 14403 Make_Selected_Component (Loc, 14404 Prefix => Make_Identifier (Loc, Name_uInit), 14405 Selector_Name => 14406 Make_Identifier (Loc, Name_uSecondary_Stack_Size))); 14407 14408 else 14409 Append_To (Args, 14410 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 14411 end if; 14412 14413 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a 14414 -- Task_Info pragma, in which case we take the value from the pragma. 14415 14416 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then 14417 Append_To (Args, 14418 Make_Selected_Component (Loc, 14419 Prefix => Make_Identifier (Loc, Name_uInit), 14420 Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); 14421 14422 else 14423 Append_To (Args, 14424 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc)); 14425 end if; 14426 14427 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item, 14428 -- in which case we take the value from the rep item. The parameter is 14429 -- passed as an Integer because in the case of unspecified CPU the 14430 -- value is not in the range of CPU_Range. 14431 14432 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then 14433 Append_To (Args, 14434 Convert_To (Standard_Integer, 14435 Make_Selected_Component (Loc, 14436 Prefix => Make_Identifier (Loc, Name_uInit), 14437 Selector_Name => Make_Identifier (Loc, Name_uCPU)))); 14438 else 14439 Append_To (Args, 14440 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc)); 14441 end if; 14442 14443 if not Restricted_Profile or else Task_Dispatching_Policy = 'E' then 14444 14445 -- Deadline parameter. If no Relative_Deadline pragma is present, 14446 -- then the deadline is Time_Span_Zero. If a pragma is present, then 14447 -- the deadline is taken from the _Relative_Deadline field of the 14448 -- task value record, which was set from the pragma value. Note that 14449 -- this parameter must not be generated for the restricted profiles 14450 -- since Ravenscar does not allow deadlines. 14451 14452 -- Case where pragma Relative_Deadline applies: use given value 14453 14454 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then 14455 Append_To (Args, 14456 Make_Selected_Component (Loc, 14457 Prefix => Make_Identifier (Loc, Name_uInit), 14458 Selector_Name => 14459 Make_Identifier (Loc, Name_uRelative_Deadline))); 14460 14461 -- No pragma Relative_Deadline apply to the task 14462 14463 else 14464 Append_To (Args, 14465 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 14466 end if; 14467 end if; 14468 14469 if not Restricted_Profile then 14470 14471 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is 14472 -- present, then the dispatching domain is null. If a rep item is 14473 -- present, then the dispatching domain is taken from the 14474 -- _Dispatching_Domain field of the task value record, which was set 14475 -- from the rep item value. 14476 14477 -- Case where Dispatching_Domain rep item applies: use given value 14478 14479 if Has_Rep_Item 14480 (Ttyp, Name_Dispatching_Domain, Check_Parents => False) 14481 then 14482 Append_To (Args, 14483 Make_Selected_Component (Loc, 14484 Prefix => 14485 Make_Identifier (Loc, Name_uInit), 14486 Selector_Name => 14487 Make_Identifier (Loc, Name_uDispatching_Domain))); 14488 14489 -- No pragma or aspect Dispatching_Domain applies to the task 14490 14491 else 14492 Append_To (Args, Make_Null (Loc)); 14493 end if; 14494 14495 -- Number of entries. This is an expression of the form: 14496 14497 -- n + _Init.a'Length + _Init.a'B'Length + ... 14498 14499 -- where a,b... are the entry family names for the task definition 14500 14501 Ecount := 14502 Build_Entry_Count_Expression 14503 (Ttyp, 14504 Component_Items 14505 (Component_List 14506 (Type_Definition 14507 (Parent (Corresponding_Record_Type (Ttyp))))), 14508 Loc); 14509 Append_To (Args, Ecount); 14510 14511 -- Master parameter. This is a reference to the _Master parameter of 14512 -- the initialization procedure, except in the case of the pragma 14513 -- Restrictions (No_Task_Hierarchy) where the value is fixed to 14514 -- System.Tasking.Library_Task_Level. 14515 14516 if Restriction_Active (No_Task_Hierarchy) = False then 14517 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 14518 else 14519 Append_To (Args, 14520 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 14521 end if; 14522 end if; 14523 14524 -- State parameter. This is a pointer to the task body procedure. The 14525 -- required value is obtained by taking 'Unrestricted_Access of the task 14526 -- body procedure and converting it (with an unchecked conversion) to 14527 -- the type required by the task kernel. For further details, see the 14528 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather 14529 -- than 'Address in order to avoid creating trampolines. 14530 14531 declare 14532 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp); 14533 Subp_Ptr_Typ : constant Node_Id := 14534 Create_Itype (E_Access_Subprogram_Type, Tdec); 14535 Ref : constant Node_Id := Make_Itype_Reference (Loc); 14536 14537 begin 14538 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc); 14539 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); 14540 14541 -- Be sure to freeze a reference to the access-to-subprogram type, 14542 -- otherwise gigi will complain that it's in the wrong scope, because 14543 -- it's actually inside the init procedure for the record type that 14544 -- corresponds to the task type. 14545 14546 Set_Itype (Ref, Subp_Ptr_Typ); 14547 Append_Freeze_Action (Task_Rec, Ref); 14548 14549 Append_To (Args, 14550 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), 14551 Make_Qualified_Expression (Loc, 14552 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), 14553 Expression => 14554 Make_Attribute_Reference (Loc, 14555 Prefix => New_Occurrence_Of (Body_Proc, Loc), 14556 Attribute_Name => Name_Unrestricted_Access)))); 14557 end; 14558 14559 -- Discriminants parameter. This is just the address of the task 14560 -- value record itself (which contains the discriminant values 14561 14562 Append_To (Args, 14563 Make_Attribute_Reference (Loc, 14564 Prefix => Make_Identifier (Loc, Name_uInit), 14565 Attribute_Name => Name_Address)); 14566 14567 -- Elaborated parameter. This is an access to the elaboration Boolean 14568 14569 Append_To (Args, 14570 Make_Attribute_Reference (Loc, 14571 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')), 14572 Attribute_Name => Name_Unchecked_Access)); 14573 14574 -- Add Chain parameter (not done for sequential elaboration policy, see 14575 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 14576 14577 if Partition_Elaboration_Policy /= 'S' then 14578 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 14579 end if; 14580 14581 -- Task name parameter. Take this from the _Task_Id parameter to the 14582 -- init call unless there is a Task_Name pragma, in which case we take 14583 -- the value from the pragma. 14584 14585 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then 14586 -- Copy expression in full, because it may be dynamic and have 14587 -- side effects. 14588 14589 Append_To (Args, 14590 New_Copy_Tree 14591 (Expression 14592 (First 14593 (Pragma_Argument_Associations 14594 (Get_Rep_Pragma 14595 (Ttyp, Name_Task_Name, Check_Parents => False)))))); 14596 14597 else 14598 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); 14599 end if; 14600 14601 -- Created_Task parameter. This is the _Task_Id field of the task 14602 -- record value 14603 14604 Append_To (Args, 14605 Make_Selected_Component (Loc, 14606 Prefix => Make_Identifier (Loc, Name_uInit), 14607 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); 14608 14609 declare 14610 Create_RE : RE_Id; 14611 14612 begin 14613 if Restricted_Profile then 14614 if Partition_Elaboration_Policy = 'S' then 14615 Create_RE := RE_Create_Restricted_Task_Sequential; 14616 else 14617 Create_RE := RE_Create_Restricted_Task; 14618 end if; 14619 else 14620 Create_RE := RE_Create_Task; 14621 end if; 14622 14623 Name := New_Occurrence_Of (RTE (Create_RE), Loc); 14624 end; 14625 14626 return 14627 Make_Procedure_Call_Statement (Loc, 14628 Name => Name, 14629 Parameter_Associations => Args); 14630 end Make_Task_Create_Call; 14631 14632 ------------------------------ 14633 -- Next_Protected_Operation -- 14634 ------------------------------ 14635 14636 function Next_Protected_Operation (N : Node_Id) return Node_Id is 14637 Next_Op : Node_Id; 14638 14639 begin 14640 -- Check whether there is a subsequent body for a protected operation 14641 -- in the current protected body. In Ada2012 that includes expression 14642 -- functions that are completions. 14643 14644 Next_Op := Next (N); 14645 while Present (Next_Op) 14646 and then not Nkind_In (Next_Op, 14647 N_Subprogram_Body, N_Entry_Body, N_Expression_Function) 14648 loop 14649 Next (Next_Op); 14650 end loop; 14651 14652 return Next_Op; 14653 end Next_Protected_Operation; 14654 14655 --------------------- 14656 -- Null_Statements -- 14657 --------------------- 14658 14659 function Null_Statements (Stats : List_Id) return Boolean is 14660 Stmt : Node_Id; 14661 14662 begin 14663 Stmt := First (Stats); 14664 while Nkind (Stmt) /= N_Empty 14665 and then (Nkind_In (Stmt, N_Null_Statement, N_Label) 14666 or else 14667 (Nkind (Stmt) = N_Pragma 14668 and then 14669 Nam_In (Pragma_Name_Unmapped (Stmt), 14670 Name_Unreferenced, 14671 Name_Unmodified, 14672 Name_Warnings))) 14673 loop 14674 Next (Stmt); 14675 end loop; 14676 14677 return Nkind (Stmt) = N_Empty; 14678 end Null_Statements; 14679 14680 -------------------------- 14681 -- Parameter_Block_Pack -- 14682 -------------------------- 14683 14684 function Parameter_Block_Pack 14685 (Loc : Source_Ptr; 14686 Blk_Typ : Entity_Id; 14687 Actuals : List_Id; 14688 Formals : List_Id; 14689 Decls : List_Id; 14690 Stmts : List_Id) return Node_Id 14691 is 14692 Actual : Entity_Id; 14693 Expr : Node_Id := Empty; 14694 Formal : Entity_Id; 14695 Has_Param : Boolean := False; 14696 P : Entity_Id; 14697 Params : List_Id; 14698 Temp_Asn : Node_Id; 14699 Temp_Nam : Node_Id; 14700 14701 begin 14702 Actual := First (Actuals); 14703 Formal := Defining_Identifier (First (Formals)); 14704 Params := New_List; 14705 while Present (Actual) loop 14706 if Is_By_Copy_Type (Etype (Actual)) then 14707 -- Generate: 14708 -- Jnn : aliased <formal-type> 14709 14710 Temp_Nam := Make_Temporary (Loc, 'J'); 14711 14712 Append_To (Decls, 14713 Make_Object_Declaration (Loc, 14714 Aliased_Present => True, 14715 Defining_Identifier => Temp_Nam, 14716 Object_Definition => 14717 New_Occurrence_Of (Etype (Formal), Loc))); 14718 14719 -- The object is initialized with an explicit assignment 14720 -- later. Indicate that it does not need an initialization 14721 -- to prevent spurious warnings if the type excludes null. 14722 14723 Set_No_Initialization (Last (Decls)); 14724 14725 if Ekind (Formal) /= E_Out_Parameter then 14726 14727 -- Generate: 14728 -- Jnn := <actual> 14729 14730 Temp_Asn := 14731 New_Occurrence_Of (Temp_Nam, Loc); 14732 14733 Set_Assignment_OK (Temp_Asn); 14734 14735 Append_To (Stmts, 14736 Make_Assignment_Statement (Loc, 14737 Name => Temp_Asn, 14738 Expression => New_Copy_Tree (Actual))); 14739 end if; 14740 14741 -- If the actual is not controlling, generate: 14742 14743 -- Jnn'unchecked_access 14744 14745 -- and add it to aggegate for access to formals. Note that the 14746 -- actual may be by-copy but still be a controlling actual if it 14747 -- is an access to class-wide interface. 14748 14749 if not Is_Controlling_Actual (Actual) then 14750 Append_To (Params, 14751 Make_Attribute_Reference (Loc, 14752 Attribute_Name => Name_Unchecked_Access, 14753 Prefix => New_Occurrence_Of (Temp_Nam, Loc))); 14754 14755 Has_Param := True; 14756 end if; 14757 14758 -- The controlling parameter is omitted 14759 14760 else 14761 if not Is_Controlling_Actual (Actual) then 14762 Append_To (Params, 14763 Make_Reference (Loc, New_Copy_Tree (Actual))); 14764 14765 Has_Param := True; 14766 end if; 14767 end if; 14768 14769 Next_Actual (Actual); 14770 Next_Formal_With_Extras (Formal); 14771 end loop; 14772 14773 if Has_Param then 14774 Expr := Make_Aggregate (Loc, Params); 14775 end if; 14776 14777 -- Generate: 14778 -- P : Ann := ( 14779 -- J1'unchecked_access; 14780 -- <actual2>'reference; 14781 -- ...); 14782 14783 P := Make_Temporary (Loc, 'P'); 14784 14785 Append_To (Decls, 14786 Make_Object_Declaration (Loc, 14787 Defining_Identifier => P, 14788 Object_Definition => New_Occurrence_Of (Blk_Typ, Loc), 14789 Expression => Expr)); 14790 14791 return P; 14792 end Parameter_Block_Pack; 14793 14794 ---------------------------- 14795 -- Parameter_Block_Unpack -- 14796 ---------------------------- 14797 14798 function Parameter_Block_Unpack 14799 (Loc : Source_Ptr; 14800 P : Entity_Id; 14801 Actuals : List_Id; 14802 Formals : List_Id) return List_Id 14803 is 14804 Actual : Entity_Id; 14805 Asnmt : Node_Id; 14806 Formal : Entity_Id; 14807 Has_Asnmt : Boolean := False; 14808 Result : constant List_Id := New_List; 14809 14810 begin 14811 Actual := First (Actuals); 14812 Formal := Defining_Identifier (First (Formals)); 14813 while Present (Actual) loop 14814 if Is_By_Copy_Type (Etype (Actual)) 14815 and then Ekind (Formal) /= E_In_Parameter 14816 then 14817 -- Generate: 14818 -- <actual> := P.<formal>; 14819 14820 Asnmt := 14821 Make_Assignment_Statement (Loc, 14822 Name => 14823 New_Copy (Actual), 14824 Expression => 14825 Make_Explicit_Dereference (Loc, 14826 Make_Selected_Component (Loc, 14827 Prefix => 14828 New_Occurrence_Of (P, Loc), 14829 Selector_Name => 14830 Make_Identifier (Loc, Chars (Formal))))); 14831 14832 Set_Assignment_OK (Name (Asnmt)); 14833 Append_To (Result, Asnmt); 14834 14835 Has_Asnmt := True; 14836 end if; 14837 14838 Next_Actual (Actual); 14839 Next_Formal_With_Extras (Formal); 14840 end loop; 14841 14842 if Has_Asnmt then 14843 return Result; 14844 else 14845 return New_List (Make_Null_Statement (Loc)); 14846 end if; 14847 end Parameter_Block_Unpack; 14848 14849 --------------------- 14850 -- Reset_Scopes_To -- 14851 --------------------- 14852 14853 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is 14854 function Reset_Scope (N : Node_Id) return Traverse_Result; 14855 -- Temporaries may have been declared during expansion of the procedure 14856 -- created for an entry body or an accept alternative. Indicate that 14857 -- their scope is the new body, to ensure proper generation of uplevel 14858 -- references where needed during unnesting. 14859 14860 procedure Reset_Scopes is new Traverse_Proc (Reset_Scope); 14861 14862 ----------------- 14863 -- Reset_Scope -- 14864 ----------------- 14865 14866 function Reset_Scope (N : Node_Id) return Traverse_Result is 14867 Decl : Node_Id; 14868 14869 begin 14870 -- If this is a block statement with an Identifier, it forms a scope, 14871 -- so we want to reset its scope but not look inside. 14872 14873 if N /= Bod 14874 and then Nkind (N) = N_Block_Statement 14875 and then Present (Identifier (N)) 14876 then 14877 Set_Scope (Entity (Identifier (N)), E); 14878 return Skip; 14879 14880 -- Ditto for a package declaration or a full type declaration, etc. 14881 14882 elsif Nkind (N) = N_Package_Declaration 14883 or else Nkind (N) in N_Declaration 14884 or else Nkind (N) in N_Renaming_Declaration 14885 then 14886 Set_Scope (Defining_Entity (N), E); 14887 return Skip; 14888 14889 elsif N = Bod then 14890 14891 -- Scan declarations in new body. Declarations in the statement 14892 -- part will be handled during later traversal. 14893 14894 Decl := First (Declarations (N)); 14895 while Present (Decl) loop 14896 Reset_Scopes (Decl); 14897 Next (Decl); 14898 end loop; 14899 14900 elsif N /= Bod and then Nkind (N) in N_Proper_Body then 14901 return Skip; 14902 end if; 14903 14904 return OK; 14905 end Reset_Scope; 14906 14907 -- Start of processing for Reset_Scopes_To 14908 14909 begin 14910 Reset_Scopes (Bod); 14911 end Reset_Scopes_To; 14912 14913 ---------------------- 14914 -- Set_Discriminals -- 14915 ---------------------- 14916 14917 procedure Set_Discriminals (Dec : Node_Id) is 14918 D : Entity_Id; 14919 Pdef : Entity_Id; 14920 D_Minal : Entity_Id; 14921 14922 begin 14923 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); 14924 Pdef := Defining_Identifier (Dec); 14925 14926 if Has_Discriminants (Pdef) then 14927 D := First_Discriminant (Pdef); 14928 while Present (D) loop 14929 D_Minal := 14930 Make_Defining_Identifier (Sloc (D), 14931 Chars => New_External_Name (Chars (D), 'D')); 14932 14933 Set_Ekind (D_Minal, E_Constant); 14934 Set_Etype (D_Minal, Etype (D)); 14935 Set_Scope (D_Minal, Pdef); 14936 Set_Discriminal (D, D_Minal); 14937 Set_Discriminal_Link (D_Minal, D); 14938 14939 Next_Discriminant (D); 14940 end loop; 14941 end if; 14942 end Set_Discriminals; 14943 14944 ----------------------- 14945 -- Trivial_Accept_OK -- 14946 ----------------------- 14947 14948 function Trivial_Accept_OK return Boolean is 14949 begin 14950 case Opt.Task_Dispatching_Policy is 14951 14952 -- If we have the default task dispatching policy in effect, we can 14953 -- definitely do the optimization (one way of looking at this is to 14954 -- think of the formal definition of the default policy being allowed 14955 -- to run any task it likes after a rendezvous, so even if notionally 14956 -- a full rescheduling occurs, we can say that our dispatching policy 14957 -- (i.e. the default dispatching policy) reorders the queue to be the 14958 -- same as just before the call. 14959 14960 when ' ' => 14961 return True; 14962 14963 -- FIFO_Within_Priorities certainly does not permit this 14964 -- optimization since the Rendezvous is a scheduling action that may 14965 -- require some other task to be run. 14966 14967 when 'F' => 14968 return False; 14969 14970 -- For now, disallow the optimization for all other policies. This 14971 -- may be over-conservative, but it is certainly not incorrect. 14972 14973 when others => 14974 return False; 14975 end case; 14976 end Trivial_Accept_OK; 14977 14978end Exp_Ch9; 14979