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_Ch5; use Sem_Ch5; 52with Sem_Ch6; use Sem_Ch6; 53with Sem_Ch8; use Sem_Ch8; 54with Sem_Ch9; use Sem_Ch9; 55with Sem_Ch11; use Sem_Ch11; 56with Sem_Elab; use Sem_Elab; 57with Sem_Eval; use Sem_Eval; 58with Sem_Prag; use Sem_Prag; 59with Sem_Res; use Sem_Res; 60with Sem_Util; use Sem_Util; 61with Sinfo; use Sinfo; 62with Snames; use Snames; 63with Stand; use Stand; 64with Targparm; use Targparm; 65with Tbuild; use Tbuild; 66with Uintp; use Uintp; 67with Validsw; use Validsw; 68 69package body Exp_Ch9 is 70 71 -- The following constant establishes the upper bound for the index of 72 -- an entry family. It is used to limit the allocated size of protected 73 -- types with defaulted discriminant of an integer type, when the bound 74 -- of some entry family depends on a discriminant. The limitation to entry 75 -- families of 128K should be reasonable in all cases, and is a documented 76 -- implementation restriction. 77 78 Entry_Family_Bound : constant Pos := 2**16; 79 80 ----------------------- 81 -- Local Subprograms -- 82 ----------------------- 83 84 function Actual_Index_Expression 85 (Sloc : Source_Ptr; 86 Ent : Entity_Id; 87 Index : Node_Id; 88 Tsk : Entity_Id) return Node_Id; 89 -- Compute the index position for an entry call. Tsk is the target task. If 90 -- the bounds of some entry family depend on discriminants, the expression 91 -- computed by this function uses the discriminants of the target task. 92 93 procedure Add_Object_Pointer 94 (Loc : Source_Ptr; 95 Conc_Typ : Entity_Id; 96 Decls : List_Id); 97 -- Prepend an object pointer declaration to the declaration list Decls. 98 -- This object pointer is initialized to a type conversion of the System. 99 -- Address pointer passed to entry barrier functions and entry body 100 -- procedures. 101 102 procedure Add_Formal_Renamings 103 (Spec : Node_Id; 104 Decls : List_Id; 105 Ent : Entity_Id; 106 Loc : Source_Ptr); 107 -- Create renaming declarations for the formals, inside the procedure that 108 -- implements an entry body. The renamings make the original names of the 109 -- formals accessible to gdb, and serve no other purpose. 110 -- Spec is the specification of the procedure being built. 111 -- Decls is the list of declarations to be enhanced. 112 -- Ent is the entity for the original entry body. 113 114 function Build_Accept_Body (Astat : Node_Id) return Node_Id; 115 -- Transform accept statement into a block with added exception handler. 116 -- Used both for simple accept statements and for accept alternatives in 117 -- select statements. Astat is the accept statement. 118 119 function Build_Barrier_Function 120 (N : Node_Id; 121 Ent : Entity_Id; 122 Pid : Node_Id) return Node_Id; 123 -- Build the function body returning the value of the barrier expression 124 -- for the specified entry body. 125 126 function Build_Barrier_Function_Specification 127 (Loc : Source_Ptr; 128 Def_Id : Entity_Id) return Node_Id; 129 -- Build a specification for a function implementing the protected entry 130 -- barrier of the specified entry body. 131 132 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id); 133 -- Build the body of a wrapper procedure for an entry or entry family that 134 -- has contract cases, preconditions, or postconditions. The body gathers 135 -- the executable contract items and expands them in the usual way, and 136 -- performs the entry call itself. This way preconditions are evaluated 137 -- before the call is queued. E is the entry in question, and Decl is the 138 -- enclosing synchronized type declaration at whose freeze point the 139 -- generated body is analyzed. 140 141 function Build_Corresponding_Record 142 (N : Node_Id; 143 Ctyp : Node_Id; 144 Loc : Source_Ptr) return Node_Id; 145 -- Common to tasks and protected types. Copy discriminant specifications, 146 -- build record declaration. N is the type declaration, Ctyp is the 147 -- concurrent entity (task type or protected type). 148 149 function Build_Dispatching_Tag_Check 150 (K : Entity_Id; 151 N : Node_Id) return Node_Id; 152 -- Utility to create the tree to check whether the dispatching call in 153 -- a timed entry call, a conditional entry call, or an asynchronous 154 -- transfer of control is a call to a primitive of a non-synchronized type. 155 -- K is the temporary that holds the tagged kind of the target object, and 156 -- N is the enclosing construct. 157 158 function Build_Entry_Count_Expression 159 (Concurrent_Type : Node_Id; 160 Component_List : List_Id; 161 Loc : Source_Ptr) return Node_Id; 162 -- Compute number of entries for concurrent object. This is a count of 163 -- simple entries, followed by an expression that computes the length 164 -- of the range of each entry family. A single array with that size is 165 -- allocated for each concurrent object of the type. 166 167 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; 168 -- Build the function that translates the entry index in the call 169 -- (which depends on the size of entry families) into an index into the 170 -- Entry_Bodies_Array, to determine the body and barrier function used 171 -- in a protected entry call. A pointer to this function appears in every 172 -- protected object. 173 174 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id; 175 -- Build subprogram declaration for previous one 176 177 function Build_Lock_Free_Protected_Subprogram_Body 178 (N : Node_Id; 179 Prot_Typ : Node_Id; 180 Unprot_Spec : Node_Id) return Node_Id; 181 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is 182 -- the subprogram specification of the unprotected version of N. Transform 183 -- N such that it invokes the unprotected version of the body. 184 185 function Build_Lock_Free_Unprotected_Subprogram_Body 186 (N : Node_Id; 187 Prot_Typ : Node_Id) return Node_Id; 188 -- N denotes a subprogram body of protected type Prot_Typ. Build a version 189 -- of N where the original statements of N are synchronized through atomic 190 -- actions such as compare and exchange. Prior to invoking this routine, it 191 -- has been established that N can be implemented in a lock-free fashion. 192 193 function Build_Parameter_Block 194 (Loc : Source_Ptr; 195 Actuals : List_Id; 196 Formals : List_Id; 197 Decls : List_Id) return Entity_Id; 198 -- Generate an access type for each actual parameter in the list Actuals. 199 -- Create an encapsulating record that contains all the actuals and return 200 -- its type. Generate: 201 -- type Ann1 is access all <actual1-type> 202 -- ... 203 -- type AnnN is access all <actualN-type> 204 -- type Pnn is record 205 -- <formal1> : Ann1; 206 -- ... 207 -- <formalN> : AnnN; 208 -- end record; 209 210 function Build_Protected_Entry 211 (N : Node_Id; 212 Ent : Entity_Id; 213 Pid : Node_Id) return Node_Id; 214 -- Build the procedure implementing the statement sequence of the specified 215 -- entry body. 216 217 function Build_Protected_Entry_Specification 218 (Loc : Source_Ptr; 219 Def_Id : Entity_Id; 220 Ent_Id : Entity_Id) return Node_Id; 221 -- Build a specification for the procedure implementing the statements of 222 -- the specified entry body. Add attributes associating it with the entry 223 -- defining identifier Ent_Id. 224 225 function Build_Protected_Spec 226 (N : Node_Id; 227 Obj_Type : Entity_Id; 228 Ident : Entity_Id; 229 Unprotected : Boolean := False) return List_Id; 230 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_ 231 -- Subprogram_Type. Builds signature of protected subprogram, adding the 232 -- formal that corresponds to the object itself. For an access to protected 233 -- subprogram, there is no object type to specify, so the parameter has 234 -- type Address and mode In. An indirect call through such a pointer will 235 -- convert the address to a reference to the actual object. The object is 236 -- a limited record and therefore a by_reference type. 237 238 function Build_Protected_Subprogram_Body 239 (N : Node_Id; 240 Pid : Node_Id; 241 N_Op_Spec : Node_Id) return Node_Id; 242 -- This function is used to construct the protected version of a protected 243 -- subprogram. Its statement sequence first defers abort, then locks the 244 -- associated protected object, and then enters a block that contains a 245 -- call to the unprotected version of the subprogram (for details, see 246 -- Build_Unprotected_Subprogram_Body). This block statement requires a 247 -- cleanup handler that unlocks the object in all cases. For details, 248 -- see Exp_Ch7.Expand_Cleanup_Actions. 249 250 function Build_Renamed_Formal_Declaration 251 (New_F : Entity_Id; 252 Formal : Entity_Id; 253 Comp : Entity_Id; 254 Renamed_Formal : Node_Id) return Node_Id; 255 -- Create a renaming declaration for a formal, within a protected entry 256 -- body or an accept body. The renamed object is a component of the 257 -- parameter block that is a parameter in the entry call. 258 -- 259 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming 260 -- does not dereference the corresponding component to prevent an illegal 261 -- use of the incomplete type (AI05-0151). 262 263 function Build_Selected_Name 264 (Prefix : Entity_Id; 265 Selector : Entity_Id; 266 Append_Char : Character := ' ') return Name_Id; 267 -- Build a name in the form of Prefix__Selector, with an optional character 268 -- appended. This is used for internal subprograms generated for operations 269 -- of protected types, including barrier functions. For the subprograms 270 -- generated for entry bodies and entry barriers, the generated name 271 -- includes a sequence number that makes names unique in the presence of 272 -- entry overloading. This is necessary because entry body procedures and 273 -- barrier functions all have the same signature. 274 275 procedure Build_Simple_Entry_Call 276 (N : Node_Id; 277 Concval : Node_Id; 278 Ename : Node_Id; 279 Index : Node_Id); 280 -- Some comments here would be useful ??? 281 282 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id; 283 -- This routine constructs a specification for the procedure that we will 284 -- build for the task body for task type T. The spec has the form: 285 -- 286 -- procedure tnameB (_Task : access tnameV); 287 -- 288 -- where name is the character name taken from the task type entity that 289 -- is passed as the argument to the procedure, and tnameV is the task 290 -- value type that is associated with the task type. 291 292 function Build_Unprotected_Subprogram_Body 293 (N : Node_Id; 294 Pid : Node_Id) return Node_Id; 295 -- This routine constructs the unprotected version of a protected 296 -- subprogram body, which contains all of the code in the original, 297 -- unexpanded body. This is the version of the protected subprogram that is 298 -- called from all protected operations on the same object, including the 299 -- protected version of the same subprogram. 300 301 procedure Build_Wrapper_Bodies 302 (Loc : Source_Ptr; 303 Typ : Entity_Id; 304 N : Node_Id); 305 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding 306 -- record of a concurrent type. N is the insertion node where all bodies 307 -- will be placed. This routine builds the bodies of the subprograms which 308 -- serve as an indirection mechanism to overriding primitives of concurrent 309 -- types, entries and protected procedures. Any new body is analyzed. 310 311 procedure Build_Wrapper_Specs 312 (Loc : Source_Ptr; 313 Typ : Entity_Id; 314 N : in out Node_Id); 315 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding 316 -- record of a concurrent type. N is the insertion node where all specs 317 -- will be placed. This routine builds the specs of the subprograms which 318 -- serve as an indirection mechanism to overriding primitives of concurrent 319 -- types, entries and protected procedures. Any new spec is analyzed. 320 321 procedure Collect_Entry_Families 322 (Loc : Source_Ptr; 323 Cdecls : List_Id; 324 Current_Node : in out Node_Id; 325 Conctyp : Entity_Id); 326 -- For each entry family in a concurrent type, create an anonymous array 327 -- type of the right size, and add a component to the corresponding_record. 328 329 function Concurrent_Object 330 (Spec_Id : Entity_Id; 331 Conc_Typ : Entity_Id) return Entity_Id; 332 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return 333 -- the entity associated with the concurrent object in the Protected_Body_ 334 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity 335 -- denotes formal parameter _O, _object or _task. 336 337 function Copy_Result_Type (Res : Node_Id) return Node_Id; 338 -- Copy the result type of a function specification, when building the 339 -- internal operation corresponding to a protected function, or when 340 -- expanding an access to protected function. If the result is an anonymous 341 -- access to subprogram itself, we need to create a new signature with the 342 -- same parameter names and the same resolved types, but with new entities 343 -- for the formals. 344 345 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean; 346 -- Return whether a secondary stack for the task T should be created by the 347 -- expander. The secondary stack for a task will be created by the expander 348 -- if the size of the stack has been specified by the Secondary_Stack_Size 349 -- representation aspect and either the No_Implicit_Heap_Allocations or 350 -- No_Implicit_Task_Allocations restrictions are in effect and the 351 -- No_Secondary_Stack restriction is not. 352 353 procedure Debug_Private_Data_Declarations (Decls : List_Id); 354 -- Decls is a list which may contain the declarations created by Install_ 355 -- Private_Data_Declarations. All generated entities are marked as needing 356 -- debug info and debug nodes are manually generation where necessary. This 357 -- step of the expansion must to be done after private data has been moved 358 -- to its final resting scope to ensure proper visibility of debug objects. 359 360 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id); 361 -- If control flow optimizations are suppressed, and Alt is an accept, 362 -- delay, or entry call alternative with no trailing statements, insert 363 -- a null trailing statement with the given Loc (which is the sloc of 364 -- the accept, delay, or entry call statement). There might not be any 365 -- generated code for the accept, delay, or entry call itself (the effect 366 -- of these statements is part of the general processing done for the 367 -- enclosing selective accept, timed entry call, or asynchronous select), 368 -- and the null statement is there to carry the sloc of that statement to 369 -- the back-end for trace-based coverage analysis purposes. 370 371 procedure Extract_Dispatching_Call 372 (N : Node_Id; 373 Call_Ent : out Entity_Id; 374 Object : out Entity_Id; 375 Actuals : out List_Id; 376 Formals : out List_Id); 377 -- Given a dispatching call, extract the entity of the name of the call, 378 -- its actual dispatching object, its actual parameters and the formal 379 -- parameters of the overridden interface-level version. If the type of 380 -- the dispatching object is an access type then an explicit dereference 381 -- is returned in Object. 382 383 procedure Extract_Entry 384 (N : Node_Id; 385 Concval : out Node_Id; 386 Ename : out Node_Id; 387 Index : out Node_Id); 388 -- Given an entry call, returns the associated concurrent object, the entry 389 -- name, and the entry family index. 390 391 function Family_Offset 392 (Loc : Source_Ptr; 393 Hi : Node_Id; 394 Lo : Node_Id; 395 Ttyp : Entity_Id; 396 Cap : Boolean) return Node_Id; 397 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an 398 -- accept statement, or the upper bound in the discrete subtype of an entry 399 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent 400 -- type of the entry. If Cap is true, the result is capped according to 401 -- Entry_Family_Bound. 402 403 function Family_Size 404 (Loc : Source_Ptr; 405 Hi : Node_Id; 406 Lo : Node_Id; 407 Ttyp : Entity_Id; 408 Cap : Boolean) return Node_Id; 409 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a 410 -- family, and handle properly the superflat case. This is equivalent to 411 -- the use of 'Length on the index type, but must use Family_Offset to 412 -- handle properly the case of bounds that depend on discriminants. If 413 -- Cap is true, the result is capped according to Entry_Family_Bound. 414 415 procedure Find_Enclosing_Context 416 (N : Node_Id; 417 Context : out Node_Id; 418 Context_Id : out Entity_Id; 419 Context_Decls : out List_Id); 420 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and 421 -- Build_Master_Entity. Given an arbitrary node in the tree, find the 422 -- nearest enclosing body, block, package, or return statement and return 423 -- its constituents. Context is the enclosing construct, Context_Id is 424 -- the scope of Context_Id and Context_Decls is the declarative list of 425 -- Context. 426 427 function Index_Object (Spec_Id : Entity_Id) return Entity_Id; 428 -- Given a subprogram identifier, return the entity which is associated 429 -- with the protection entry index in the Protected_Body_Subprogram or 430 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal 431 -- parameter _E. 432 433 function Is_Potentially_Large_Family 434 (Base_Index : Entity_Id; 435 Conctyp : Entity_Id; 436 Lo : Node_Id; 437 Hi : Node_Id) return Boolean; 438 439 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean; 440 -- Determine whether Id is a function or a procedure and is marked as a 441 -- private primitive. 442 443 function Null_Statements (Stats : List_Id) return Boolean; 444 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. 445 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well 446 -- to still count as null. Returns True for a null sequence. The argument 447 -- is the list of statements from the DO-END sequence. 448 449 function Parameter_Block_Pack 450 (Loc : Source_Ptr; 451 Blk_Typ : Entity_Id; 452 Actuals : List_Id; 453 Formals : List_Id; 454 Decls : List_Id; 455 Stmts : List_Id) return Entity_Id; 456 -- Set the components of the generated parameter block with the values 457 -- of the actual parameters. Generate aliased temporaries to capture the 458 -- values for types that are passed by copy. Otherwise generate a reference 459 -- to the actual's value. Return the address of the aggregate block. 460 -- Generate: 461 -- Jnn1 : alias <formal-type1>; 462 -- Jnn1 := <actual1>; 463 -- ... 464 -- P : Blk_Typ := ( 465 -- Jnn1'unchecked_access; 466 -- <actual2>'reference; 467 -- ...); 468 469 function Parameter_Block_Unpack 470 (Loc : Source_Ptr; 471 P : Entity_Id; 472 Actuals : List_Id; 473 Formals : List_Id) return List_Id; 474 -- Retrieve the values of the components from the parameter block and 475 -- assign then to the original actual parameters. Generate: 476 -- <actual1> := P.<formal1>; 477 -- ... 478 -- <actualN> := P.<formalN>; 479 480 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id); 481 -- Reset the scope of declarations and blocks at the top level of Bod to 482 -- be E. Bod is either a block or a subprogram body. Used after expanding 483 -- various kinds of entry bodies into their corresponding constructs. This 484 -- is needed during unnesting to determine whether a body generated for an 485 -- entry or an accept alternative includes uplevel 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 -- Very similar to Move_Pragmas in sem_ch6 ??? 3499 3500 --------------------- 3501 -- Analyze_Pragmas -- 3502 --------------------- 3503 3504 procedure Analyze_Pragmas (From : Node_Id) is 3505 Decl : Node_Id; 3506 3507 begin 3508 Decl := Next (From); 3509 while Present (Decl) loop 3510 if Nkind (Decl) = N_Pragma then 3511 Analyze_Pragma (Decl); 3512 3513 -- No candidate pragmas are available for analysis 3514 3515 else 3516 exit; 3517 end if; 3518 3519 Next (Decl); 3520 end loop; 3521 end Analyze_Pragmas; 3522 3523 ------------------ 3524 -- Move_Pragmas -- 3525 ------------------ 3526 3527 procedure Move_Pragmas (From : Node_Id; To : Node_Id) is 3528 Decl : Node_Id; 3529 Insert_Nod : Node_Id; 3530 Next_Decl : Node_Id; 3531 3532 begin 3533 pragma Assert (Nkind (From) = N_Subprogram_Body); 3534 3535 -- The pragmas are moved in an order-preserving fashion 3536 3537 Insert_Nod := To; 3538 3539 -- Inspect the declarations of the subprogram body and relocate all 3540 -- candidate pragmas. 3541 3542 Decl := First (Declarations (From)); 3543 while Present (Decl) loop 3544 3545 -- Preserve the following declaration for iteration purposes, due 3546 -- to possible relocation of a pragma. 3547 3548 Next_Decl := Next (Decl); 3549 3550 -- We add an exception here for Unreferenced pragmas since the 3551 -- internally generated spec gets analyzed within 3552 -- Build_Private_Protected_Declaration and will lead to spurious 3553 -- warnings due to the way references are checked. 3554 3555 if Nkind (Decl) = N_Pragma 3556 and then Pragma_Name_Unmapped (Decl) /= Name_Unreferenced 3557 then 3558 Remove (Decl); 3559 Insert_After (Insert_Nod, Decl); 3560 Insert_Nod := Decl; 3561 3562 -- Skip internally generated code 3563 3564 elsif not Comes_From_Source (Decl) then 3565 null; 3566 3567 -- No candidate pragmas are available for relocation 3568 3569 else 3570 exit; 3571 end if; 3572 3573 Decl := Next_Decl; 3574 end loop; 3575 end Move_Pragmas; 3576 3577 -- Local variables 3578 3579 Body_Id : constant Entity_Id := Defining_Entity (N); 3580 Loc : constant Source_Ptr := Sloc (N); 3581 Decl : Node_Id; 3582 Formal : Entity_Id; 3583 Formals : List_Id; 3584 Spec : Node_Id; 3585 Spec_Id : Entity_Id; 3586 3587 -- Start of processing for Build_Private_Protected_Declaration 3588 3589 begin 3590 Formal := First_Formal (Body_Id); 3591 3592 -- The protected operation always has at least one formal, namely the 3593 -- object itself, but it is only placed in the parameter list if 3594 -- expansion is enabled. 3595 3596 if Present (Formal) or else Expander_Active then 3597 Formals := Copy_Parameter_List (Body_Id); 3598 else 3599 Formals := No_List; 3600 end if; 3601 3602 Spec_Id := 3603 Make_Defining_Identifier (Sloc (Body_Id), 3604 Chars => Chars (Body_Id)); 3605 3606 -- Indicate that the entity comes from source, to ensure that cross- 3607 -- reference information is properly generated. The body itself is 3608 -- rewritten during expansion, and the body entity will not appear in 3609 -- calls to the operation. 3610 3611 Set_Comes_From_Source (Spec_Id, True); 3612 3613 if Nkind (Specification (N)) = N_Procedure_Specification then 3614 Spec := 3615 Make_Procedure_Specification (Loc, 3616 Defining_Unit_Name => Spec_Id, 3617 Parameter_Specifications => Formals); 3618 else 3619 Spec := 3620 Make_Function_Specification (Loc, 3621 Defining_Unit_Name => Spec_Id, 3622 Parameter_Specifications => Formals, 3623 Result_Definition => 3624 New_Occurrence_Of (Etype (Body_Id), Loc)); 3625 end if; 3626 3627 Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); 3628 Set_Corresponding_Body (Decl, Body_Id); 3629 Set_Corresponding_Spec (N, Spec_Id); 3630 3631 Insert_Before (N, Decl); 3632 3633 -- Associate all aspects and pragmas of the body with the spec. This 3634 -- ensures that these annotations apply to the initial declaration of 3635 -- the subprogram body. 3636 3637 Move_Aspects (From => N, To => Decl); 3638 Move_Pragmas (From => N, To => Decl); 3639 3640 Analyze (Decl); 3641 3642 -- The analysis of the spec may generate pragmas which require manual 3643 -- analysis. Since the generation of the spec and the relocation of the 3644 -- annotations is driven by the expansion of the stand-alone body, the 3645 -- pragmas will not be analyzed in a timely manner. Do this now. 3646 3647 Analyze_Pragmas (Decl); 3648 3649 Set_Convention (Spec_Id, Convention_Protected); 3650 Set_Has_Completion (Spec_Id); 3651 3652 return Spec_Id; 3653 end Build_Private_Protected_Declaration; 3654 3655 --------------------------- 3656 -- Build_Protected_Entry -- 3657 --------------------------- 3658 3659 function Build_Protected_Entry 3660 (N : Node_Id; 3661 Ent : Entity_Id; 3662 Pid : Node_Id) return Node_Id 3663 is 3664 Bod_Decls : constant List_Id := New_List; 3665 Decls : constant List_Id := Declarations (N); 3666 End_Lab : constant Node_Id := 3667 End_Label (Handled_Statement_Sequence (N)); 3668 End_Loc : constant Source_Ptr := 3669 Sloc (Last (Statements (Handled_Statement_Sequence (N)))); 3670 -- Used for the generated call to Complete_Entry_Body 3671 3672 Loc : constant Source_Ptr := Sloc (N); 3673 3674 Bod_Id : Entity_Id; 3675 Bod_Spec : Node_Id; 3676 Bod_Stmts : List_Id; 3677 Complete : Node_Id; 3678 Ohandle : Node_Id; 3679 Proc_Body : Node_Id; 3680 3681 EH_Loc : Source_Ptr; 3682 -- Used for the exception handler, inserted at end of the body 3683 3684 begin 3685 -- Set the source location on the exception handler only when debugging 3686 -- the expanded code (see Make_Implicit_Exception_Handler). 3687 3688 if Debug_Generated_Code then 3689 EH_Loc := End_Loc; 3690 3691 -- Otherwise the inserted code should not be visible to the debugger 3692 3693 else 3694 EH_Loc := No_Location; 3695 end if; 3696 3697 Bod_Id := 3698 Make_Defining_Identifier (Loc, 3699 Chars => Chars (Protected_Body_Subprogram (Ent))); 3700 Bod_Spec := Build_Protected_Entry_Specification (Loc, Bod_Id, Empty); 3701 3702 -- Add the following declarations: 3703 3704 -- type poVP is access poV; 3705 -- _object : poVP := poVP (_O); 3706 3707 -- where _O is the formal parameter associated with the concurrent 3708 -- object. These declarations are needed for Complete_Entry_Body. 3709 3710 Add_Object_Pointer (Loc, Pid, Bod_Decls); 3711 3712 -- Add renamings for all formals, the Protection object, discriminals, 3713 -- privals and the entry index constant for use by debugger. 3714 3715 Add_Formal_Renamings (Bod_Spec, Bod_Decls, Ent, Loc); 3716 Debug_Private_Data_Declarations (Decls); 3717 3718 -- Put the declarations and the statements from the entry 3719 3720 Bod_Stmts := 3721 New_List ( 3722 Make_Block_Statement (Loc, 3723 Declarations => Decls, 3724 Handled_Statement_Sequence => Handled_Statement_Sequence (N))); 3725 3726 -- Analyze now and reset scopes for declarations so that Scope fields 3727 -- currently denoting the entry will now denote the block scope, and 3728 -- the block's scope will be set to the new procedure entity. 3729 3730 Analyze_Statements (Bod_Stmts); 3731 3732 Set_Scope (Entity (Identifier (First (Bod_Stmts))), Bod_Id); 3733 3734 Reset_Scopes_To 3735 (First (Bod_Stmts), Entity (Identifier (First (Bod_Stmts)))); 3736 3737 case Corresponding_Runtime_Package (Pid) is 3738 when System_Tasking_Protected_Objects_Entries => 3739 Append_To (Bod_Stmts, 3740 Make_Procedure_Call_Statement (End_Loc, 3741 Name => 3742 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc), 3743 Parameter_Associations => New_List ( 3744 Make_Attribute_Reference (End_Loc, 3745 Prefix => 3746 Make_Selected_Component (End_Loc, 3747 Prefix => 3748 Make_Identifier (End_Loc, Name_uObject), 3749 Selector_Name => 3750 Make_Identifier (End_Loc, Name_uObject)), 3751 Attribute_Name => Name_Unchecked_Access)))); 3752 3753 when System_Tasking_Protected_Objects_Single_Entry => 3754 3755 -- Historically, a call to Complete_Single_Entry_Body was 3756 -- inserted, but it was a null procedure. 3757 3758 null; 3759 3760 when others => 3761 raise Program_Error; 3762 end case; 3763 3764 -- When exceptions cannot be propagated, we never need to call 3765 -- Exception_Complete_Entry_Body. 3766 3767 if No_Exception_Handlers_Set then 3768 return 3769 Make_Subprogram_Body (Loc, 3770 Specification => Bod_Spec, 3771 Declarations => Bod_Decls, 3772 Handled_Statement_Sequence => 3773 Make_Handled_Sequence_Of_Statements (Loc, 3774 Statements => Bod_Stmts, 3775 End_Label => End_Lab)); 3776 3777 else 3778 Ohandle := Make_Others_Choice (Loc); 3779 Set_All_Others (Ohandle); 3780 3781 case Corresponding_Runtime_Package (Pid) is 3782 when System_Tasking_Protected_Objects_Entries => 3783 Complete := 3784 New_Occurrence_Of 3785 (RTE (RE_Exceptional_Complete_Entry_Body), Loc); 3786 3787 when System_Tasking_Protected_Objects_Single_Entry => 3788 Complete := 3789 New_Occurrence_Of 3790 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); 3791 3792 when others => 3793 raise Program_Error; 3794 end case; 3795 3796 -- Establish link between subprogram body entity and source entry 3797 3798 Set_Corresponding_Protected_Entry (Bod_Id, Ent); 3799 3800 -- Create body of entry procedure. The renaming declarations are 3801 -- placed ahead of the block that contains the actual entry body. 3802 3803 Proc_Body := 3804 Make_Subprogram_Body (Loc, 3805 Specification => Bod_Spec, 3806 Declarations => Bod_Decls, 3807 Handled_Statement_Sequence => 3808 Make_Handled_Sequence_Of_Statements (Loc, 3809 Statements => Bod_Stmts, 3810 End_Label => End_Lab, 3811 Exception_Handlers => New_List ( 3812 Make_Implicit_Exception_Handler (EH_Loc, 3813 Exception_Choices => New_List (Ohandle), 3814 3815 Statements => New_List ( 3816 Make_Procedure_Call_Statement (EH_Loc, 3817 Name => Complete, 3818 Parameter_Associations => New_List ( 3819 Make_Attribute_Reference (EH_Loc, 3820 Prefix => 3821 Make_Selected_Component (EH_Loc, 3822 Prefix => 3823 Make_Identifier (EH_Loc, Name_uObject), 3824 Selector_Name => 3825 Make_Identifier (EH_Loc, Name_uObject)), 3826 Attribute_Name => Name_Unchecked_Access), 3827 3828 Make_Function_Call (EH_Loc, 3829 Name => 3830 New_Occurrence_Of 3831 (RTE (RE_Get_GNAT_Exception), Loc))))))))); 3832 3833 Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent)); 3834 return Proc_Body; 3835 end if; 3836 end Build_Protected_Entry; 3837 3838 ----------------------------------------- 3839 -- Build_Protected_Entry_Specification -- 3840 ----------------------------------------- 3841 3842 function Build_Protected_Entry_Specification 3843 (Loc : Source_Ptr; 3844 Def_Id : Entity_Id; 3845 Ent_Id : Entity_Id) return Node_Id 3846 is 3847 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP); 3848 3849 begin 3850 Set_Debug_Info_Needed (Def_Id); 3851 3852 if Present (Ent_Id) then 3853 Append_Elmt (P, Accept_Address (Ent_Id)); 3854 end if; 3855 3856 return 3857 Make_Procedure_Specification (Loc, 3858 Defining_Unit_Name => Def_Id, 3859 Parameter_Specifications => New_List ( 3860 Make_Parameter_Specification (Loc, 3861 Defining_Identifier => 3862 Make_Defining_Identifier (Loc, Name_uO), 3863 Parameter_Type => 3864 New_Occurrence_Of (RTE (RE_Address), Loc)), 3865 3866 Make_Parameter_Specification (Loc, 3867 Defining_Identifier => P, 3868 Parameter_Type => 3869 New_Occurrence_Of (RTE (RE_Address), Loc)), 3870 3871 Make_Parameter_Specification (Loc, 3872 Defining_Identifier => 3873 Make_Defining_Identifier (Loc, Name_uE), 3874 Parameter_Type => 3875 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)))); 3876 end Build_Protected_Entry_Specification; 3877 3878 -------------------------- 3879 -- Build_Protected_Spec -- 3880 -------------------------- 3881 3882 function Build_Protected_Spec 3883 (N : Node_Id; 3884 Obj_Type : Entity_Id; 3885 Ident : Entity_Id; 3886 Unprotected : Boolean := False) return List_Id 3887 is 3888 Loc : constant Source_Ptr := Sloc (N); 3889 Decl : Node_Id; 3890 Formal : Entity_Id; 3891 New_Plist : List_Id; 3892 New_Param : Node_Id; 3893 3894 begin 3895 New_Plist := New_List; 3896 3897 Formal := First_Formal (Ident); 3898 while Present (Formal) loop 3899 New_Param := 3900 Make_Parameter_Specification (Loc, 3901 Defining_Identifier => 3902 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 3903 Aliased_Present => Aliased_Present (Parent (Formal)), 3904 In_Present => In_Present (Parent (Formal)), 3905 Out_Present => Out_Present (Parent (Formal)), 3906 Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc)); 3907 3908 if Unprotected then 3909 Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); 3910 Set_Ekind (Defining_Identifier (New_Param), Ekind (Formal)); 3911 end if; 3912 3913 Append (New_Param, New_Plist); 3914 Next_Formal (Formal); 3915 end loop; 3916 3917 -- If the subprogram is a procedure and the context is not an access 3918 -- to protected subprogram, the parameter is in-out. Otherwise it is 3919 -- an in parameter. 3920 3921 Decl := 3922 Make_Parameter_Specification (Loc, 3923 Defining_Identifier => 3924 Make_Defining_Identifier (Loc, Name_uObject), 3925 In_Present => True, 3926 Out_Present => 3927 (Etype (Ident) = Standard_Void_Type 3928 and then not Is_RTE (Obj_Type, RE_Address)), 3929 Parameter_Type => 3930 New_Occurrence_Of (Obj_Type, Loc)); 3931 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 3932 Prepend_To (New_Plist, Decl); 3933 3934 return New_Plist; 3935 end Build_Protected_Spec; 3936 3937 --------------------------------------- 3938 -- Build_Protected_Sub_Specification -- 3939 --------------------------------------- 3940 3941 function Build_Protected_Sub_Specification 3942 (N : Node_Id; 3943 Prot_Typ : Entity_Id; 3944 Mode : Subprogram_Protection_Mode) return Node_Id 3945 is 3946 Loc : constant Source_Ptr := Sloc (N); 3947 Decl : Node_Id; 3948 Def_Id : Entity_Id; 3949 New_Id : Entity_Id; 3950 New_Plist : List_Id; 3951 New_Spec : Node_Id; 3952 3953 Append_Chr : constant array (Subprogram_Protection_Mode) of Character := 3954 (Dispatching_Mode => ' ', 3955 Protected_Mode => 'P', 3956 Unprotected_Mode => 'N'); 3957 3958 begin 3959 if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body 3960 then 3961 Decl := Unit_Declaration_Node (Corresponding_Spec (N)); 3962 else 3963 Decl := N; 3964 end if; 3965 3966 Def_Id := Defining_Unit_Name (Specification (Decl)); 3967 3968 New_Plist := 3969 Build_Protected_Spec 3970 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id, 3971 Mode = Unprotected_Mode); 3972 New_Id := 3973 Make_Defining_Identifier (Loc, 3974 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); 3975 3976 -- Reference the original nondispatching subprogram since the analysis 3977 -- of the object.operation notation may need its original name (see 3978 -- Sem_Ch4.Names_Match). 3979 3980 if Mode = Dispatching_Mode then 3981 Set_Ekind (New_Id, Ekind (Def_Id)); 3982 Set_Original_Protected_Subprogram (New_Id, Def_Id); 3983 end if; 3984 3985 -- Link the protected or unprotected version to the original subprogram 3986 -- it emulates. 3987 3988 Set_Ekind (New_Id, Ekind (Def_Id)); 3989 Set_Protected_Subprogram (New_Id, Def_Id); 3990 3991 -- The unprotected operation carries the user code, and debugging 3992 -- information must be generated for it, even though this spec does 3993 -- not come from source. It is also convenient to allow gdb to step 3994 -- into the protected operation, even though it only contains lock/ 3995 -- unlock calls. 3996 3997 Set_Debug_Info_Needed (New_Id); 3998 3999 -- If a pragma Eliminate applies to the source entity, the internal 4000 -- subprograms will be eliminated as well. 4001 4002 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id)); 4003 4004 if Nkind (Specification (Decl)) = N_Procedure_Specification then 4005 New_Spec := 4006 Make_Procedure_Specification (Loc, 4007 Defining_Unit_Name => New_Id, 4008 Parameter_Specifications => New_Plist); 4009 4010 -- Create a new specification for the anonymous subprogram type 4011 4012 else 4013 New_Spec := 4014 Make_Function_Specification (Loc, 4015 Defining_Unit_Name => New_Id, 4016 Parameter_Specifications => New_Plist, 4017 Result_Definition => 4018 Copy_Result_Type (Result_Definition (Specification (Decl)))); 4019 4020 Set_Return_Present (Defining_Unit_Name (New_Spec)); 4021 end if; 4022 4023 return New_Spec; 4024 end Build_Protected_Sub_Specification; 4025 4026 ------------------------------------- 4027 -- Build_Protected_Subprogram_Body -- 4028 ------------------------------------- 4029 4030 function Build_Protected_Subprogram_Body 4031 (N : Node_Id; 4032 Pid : Node_Id; 4033 N_Op_Spec : Node_Id) return Node_Id 4034 is 4035 Exc_Safe : constant Boolean := not Might_Raise (N); 4036 -- True if N cannot raise an exception 4037 4038 Loc : constant Source_Ptr := Sloc (N); 4039 Op_Spec : constant Node_Id := Specification (N); 4040 P_Op_Spec : constant Node_Id := 4041 Build_Protected_Sub_Specification (N, Pid, Protected_Mode); 4042 4043 Lock_Kind : RE_Id; 4044 Lock_Name : Node_Id; 4045 Lock_Stmt : Node_Id; 4046 Object_Parm : Node_Id; 4047 Pformal : Node_Id; 4048 R : Node_Id; 4049 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning 4050 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning 4051 Stmts : List_Id; 4052 Sub_Body : Node_Id; 4053 Uactuals : List_Id; 4054 Unprot_Call : Node_Id; 4055 4056 begin 4057 -- Build a list of the formal parameters of the protected version of 4058 -- the subprogram to use as the actual parameters of the unprotected 4059 -- version. 4060 4061 Uactuals := New_List; 4062 Pformal := First (Parameter_Specifications (P_Op_Spec)); 4063 while Present (Pformal) loop 4064 Append_To (Uactuals, 4065 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal)))); 4066 Next (Pformal); 4067 end loop; 4068 4069 -- Make a call to the unprotected version of the subprogram built above 4070 -- for use by the protected version built below. 4071 4072 if Nkind (Op_Spec) = N_Function_Specification then 4073 if Exc_Safe then 4074 R := Make_Temporary (Loc, 'R'); 4075 4076 Unprot_Call := 4077 Make_Object_Declaration (Loc, 4078 Defining_Identifier => R, 4079 Constant_Present => True, 4080 Object_Definition => 4081 New_Copy (Result_Definition (N_Op_Spec)), 4082 Expression => 4083 Make_Function_Call (Loc, 4084 Name => 4085 Make_Identifier (Loc, 4086 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 4087 Parameter_Associations => Uactuals)); 4088 4089 Return_Stmt := 4090 Make_Simple_Return_Statement (Loc, 4091 Expression => New_Occurrence_Of (R, Loc)); 4092 4093 else 4094 Unprot_Call := 4095 Make_Simple_Return_Statement (Loc, 4096 Expression => 4097 Make_Function_Call (Loc, 4098 Name => 4099 Make_Identifier (Loc, 4100 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 4101 Parameter_Associations => Uactuals)); 4102 end if; 4103 4104 Lock_Kind := RE_Lock_Read_Only; 4105 4106 else 4107 Unprot_Call := 4108 Make_Procedure_Call_Statement (Loc, 4109 Name => 4110 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), 4111 Parameter_Associations => Uactuals); 4112 4113 Lock_Kind := RE_Lock; 4114 end if; 4115 4116 -- Wrap call in block that will be covered by an at_end handler 4117 4118 if not Exc_Safe then 4119 Unprot_Call := 4120 Make_Block_Statement (Loc, 4121 Handled_Statement_Sequence => 4122 Make_Handled_Sequence_Of_Statements (Loc, 4123 Statements => New_List (Unprot_Call))); 4124 end if; 4125 4126 -- Make the protected subprogram body. This locks the protected 4127 -- object and calls the unprotected version of the subprogram. 4128 4129 case Corresponding_Runtime_Package (Pid) is 4130 when System_Tasking_Protected_Objects_Entries => 4131 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc); 4132 4133 when System_Tasking_Protected_Objects_Single_Entry => 4134 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc); 4135 4136 when System_Tasking_Protected_Objects => 4137 Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc); 4138 4139 when others => 4140 raise Program_Error; 4141 end case; 4142 4143 Object_Parm := 4144 Make_Attribute_Reference (Loc, 4145 Prefix => 4146 Make_Selected_Component (Loc, 4147 Prefix => Make_Identifier (Loc, Name_uObject), 4148 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4149 Attribute_Name => Name_Unchecked_Access); 4150 4151 Lock_Stmt := 4152 Make_Procedure_Call_Statement (Loc, 4153 Name => Lock_Name, 4154 Parameter_Associations => New_List (Object_Parm)); 4155 4156 if Abort_Allowed then 4157 Stmts := New_List ( 4158 Build_Runtime_Call (Loc, RE_Abort_Defer), 4159 Lock_Stmt); 4160 4161 else 4162 Stmts := New_List (Lock_Stmt); 4163 end if; 4164 4165 if not Exc_Safe then 4166 Append (Unprot_Call, Stmts); 4167 else 4168 if Nkind (Op_Spec) = N_Function_Specification then 4169 Pre_Stmts := Stmts; 4170 Stmts := Empty_List; 4171 else 4172 Append (Unprot_Call, Stmts); 4173 end if; 4174 4175 -- Historical note: Previously, call to the cleanup was inserted 4176 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup, 4177 -- which is also shared by the 'not Exc_Safe' path. 4178 4179 Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts); 4180 4181 if Nkind (Op_Spec) = N_Function_Specification then 4182 Append_To (Stmts, Return_Stmt); 4183 Append_To (Pre_Stmts, 4184 Make_Block_Statement (Loc, 4185 Declarations => New_List (Unprot_Call), 4186 Handled_Statement_Sequence => 4187 Make_Handled_Sequence_Of_Statements (Loc, 4188 Statements => Stmts))); 4189 Stmts := Pre_Stmts; 4190 end if; 4191 end if; 4192 4193 Sub_Body := 4194 Make_Subprogram_Body (Loc, 4195 Declarations => Empty_List, 4196 Specification => P_Op_Spec, 4197 Handled_Statement_Sequence => 4198 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); 4199 4200 -- Mark this subprogram as a protected subprogram body so that the 4201 -- cleanup will be inserted. This is done only in the 'not Exc_Safe' 4202 -- path as otherwise the cleanup has already been inserted. 4203 4204 if not Exc_Safe then 4205 Set_Is_Protected_Subprogram_Body (Sub_Body); 4206 end if; 4207 4208 return Sub_Body; 4209 end Build_Protected_Subprogram_Body; 4210 4211 ------------------------------------- 4212 -- Build_Protected_Subprogram_Call -- 4213 ------------------------------------- 4214 4215 procedure Build_Protected_Subprogram_Call 4216 (N : Node_Id; 4217 Name : Node_Id; 4218 Rec : Node_Id; 4219 External : Boolean := True) 4220 is 4221 Loc : constant Source_Ptr := Sloc (N); 4222 Sub : constant Entity_Id := Entity (Name); 4223 New_Sub : Node_Id; 4224 Params : List_Id; 4225 4226 begin 4227 if External then 4228 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc); 4229 else 4230 New_Sub := 4231 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc); 4232 end if; 4233 4234 if Present (Parameter_Associations (N)) then 4235 Params := New_Copy_List_Tree (Parameter_Associations (N)); 4236 else 4237 Params := New_List; 4238 end if; 4239 4240 -- If the type is an untagged derived type, convert to the root type, 4241 -- which is the one on which the operations are defined. 4242 4243 if Nkind (Rec) = N_Unchecked_Type_Conversion 4244 and then not Is_Tagged_Type (Etype (Rec)) 4245 and then Is_Derived_Type (Etype (Rec)) 4246 then 4247 Set_Etype (Rec, Root_Type (Etype (Rec))); 4248 Set_Subtype_Mark (Rec, 4249 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N))); 4250 end if; 4251 4252 Prepend (Rec, Params); 4253 4254 if Ekind (Sub) = E_Procedure then 4255 Rewrite (N, 4256 Make_Procedure_Call_Statement (Loc, 4257 Name => New_Sub, 4258 Parameter_Associations => Params)); 4259 4260 else 4261 pragma Assert (Ekind (Sub) = E_Function); 4262 Rewrite (N, 4263 Make_Function_Call (Loc, 4264 Name => New_Sub, 4265 Parameter_Associations => Params)); 4266 4267 -- Preserve type of call for subsequent processing (required for 4268 -- call to Wrap_Transient_Expression in the case of a shared passive 4269 -- protected). 4270 4271 Set_Etype (N, Etype (New_Sub)); 4272 end if; 4273 4274 if External 4275 and then Nkind (Rec) = N_Unchecked_Type_Conversion 4276 and then Is_Entity_Name (Expression (Rec)) 4277 and then Is_Shared_Passive (Entity (Expression (Rec))) 4278 then 4279 Add_Shared_Var_Lock_Procs (N); 4280 end if; 4281 end Build_Protected_Subprogram_Call; 4282 4283 --------------------------------------------- 4284 -- Build_Protected_Subprogram_Call_Cleanup -- 4285 --------------------------------------------- 4286 4287 procedure Build_Protected_Subprogram_Call_Cleanup 4288 (Op_Spec : Node_Id; 4289 Conc_Typ : Node_Id; 4290 Loc : Source_Ptr; 4291 Stmts : List_Id) 4292 is 4293 Nam : Node_Id; 4294 4295 begin 4296 -- If the associated protected object has entries, a protected 4297 -- procedure has to service entry queues. In this case generate: 4298 4299 -- Service_Entries (_object._object'Access); 4300 4301 if Nkind (Op_Spec) = N_Procedure_Specification 4302 and then Has_Entries (Conc_Typ) 4303 then 4304 case Corresponding_Runtime_Package (Conc_Typ) is 4305 when System_Tasking_Protected_Objects_Entries => 4306 Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc); 4307 4308 when System_Tasking_Protected_Objects_Single_Entry => 4309 Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc); 4310 4311 when others => 4312 raise Program_Error; 4313 end case; 4314 4315 Append_To (Stmts, 4316 Make_Procedure_Call_Statement (Loc, 4317 Name => Nam, 4318 Parameter_Associations => New_List ( 4319 Make_Attribute_Reference (Loc, 4320 Prefix => 4321 Make_Selected_Component (Loc, 4322 Prefix => Make_Identifier (Loc, Name_uObject), 4323 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4324 Attribute_Name => Name_Unchecked_Access)))); 4325 4326 else 4327 -- Generate: 4328 -- Unlock (_object._object'Access); 4329 4330 case Corresponding_Runtime_Package (Conc_Typ) is 4331 when System_Tasking_Protected_Objects_Entries => 4332 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc); 4333 4334 when System_Tasking_Protected_Objects_Single_Entry => 4335 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc); 4336 4337 when System_Tasking_Protected_Objects => 4338 Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc); 4339 4340 when others => 4341 raise Program_Error; 4342 end case; 4343 4344 Append_To (Stmts, 4345 Make_Procedure_Call_Statement (Loc, 4346 Name => Nam, 4347 Parameter_Associations => New_List ( 4348 Make_Attribute_Reference (Loc, 4349 Prefix => 4350 Make_Selected_Component (Loc, 4351 Prefix => Make_Identifier (Loc, Name_uObject), 4352 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4353 Attribute_Name => Name_Unchecked_Access)))); 4354 end if; 4355 4356 -- Generate: 4357 -- Abort_Undefer; 4358 4359 if Abort_Allowed then 4360 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 4361 end if; 4362 end Build_Protected_Subprogram_Call_Cleanup; 4363 4364 ------------------------- 4365 -- Build_Selected_Name -- 4366 ------------------------- 4367 4368 function Build_Selected_Name 4369 (Prefix : Entity_Id; 4370 Selector : Entity_Id; 4371 Append_Char : Character := ' ') return Name_Id 4372 is 4373 Select_Buffer : String (1 .. Hostparm.Max_Name_Length); 4374 Select_Len : Natural; 4375 4376 begin 4377 Get_Name_String (Chars (Selector)); 4378 Select_Len := Name_Len; 4379 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len); 4380 Get_Name_String (Chars (Prefix)); 4381 4382 -- If scope is anonymous type, discard suffix to recover name of 4383 -- single protected object. Otherwise use protected type name. 4384 4385 if Name_Buffer (Name_Len) = 'T' then 4386 Name_Len := Name_Len - 1; 4387 end if; 4388 4389 Add_Str_To_Name_Buffer ("__"); 4390 for J in 1 .. Select_Len loop 4391 Add_Char_To_Name_Buffer (Select_Buffer (J)); 4392 end loop; 4393 4394 -- Now add the Append_Char if specified. The encoding to follow 4395 -- depends on the type of entity. If Append_Char is either 'N' or 'P', 4396 -- then the entity is associated to a protected type subprogram. 4397 -- Otherwise, it is a protected type entry. For each case, the 4398 -- encoding to follow for the suffix is documented in exp_dbug.ads. 4399 4400 -- It would be better to encapsulate this as a routine in Exp_Dbug ??? 4401 4402 if Append_Char /= ' ' then 4403 if Append_Char = 'P' or Append_Char = 'N' then 4404 Add_Char_To_Name_Buffer (Append_Char); 4405 return Name_Find; 4406 else 4407 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char)); 4408 return New_External_Name (Name_Find, ' ', -1); 4409 end if; 4410 else 4411 return Name_Find; 4412 end if; 4413 end Build_Selected_Name; 4414 4415 ----------------------------- 4416 -- Build_Simple_Entry_Call -- 4417 ----------------------------- 4418 4419 -- A task entry call is converted to a call to Call_Simple 4420 4421 -- declare 4422 -- P : parms := (parm, parm, parm); 4423 -- begin 4424 -- Call_Simple (acceptor-task, entry-index, P'Address); 4425 -- parm := P.param; 4426 -- parm := P.param; 4427 -- ... 4428 -- end; 4429 4430 -- Here Pnn is an aggregate of the type constructed for the entry to hold 4431 -- the parameters, and the constructed aggregate value contains either the 4432 -- parameters or, in the case of non-elementary types, references to these 4433 -- parameters. Then the address of this aggregate is passed to the runtime 4434 -- routine, along with the task id value and the task entry index value. 4435 -- Pnn is only required if parameters are present. 4436 4437 -- The assignments after the call are present only in the case of in-out 4438 -- or out parameters for elementary types, and are used to assign back the 4439 -- resulting values of such parameters. 4440 4441 -- Note: the reason that we insert a block here is that in the context 4442 -- of selects, conditional entry calls etc. the entry call statement 4443 -- appears on its own, not as an element of a list. 4444 4445 -- A protected entry call is converted to a Protected_Entry_Call: 4446 4447 -- declare 4448 -- P : E1_Params := (param, param, param); 4449 -- Pnn : Boolean; 4450 -- Bnn : Communications_Block; 4451 4452 -- declare 4453 -- P : E1_Params := (param, param, param); 4454 -- Bnn : Communications_Block; 4455 4456 -- begin 4457 -- Protected_Entry_Call ( 4458 -- Object => po._object'Access, 4459 -- E => <entry index>; 4460 -- Uninterpreted_Data => P'Address; 4461 -- Mode => Simple_Call; 4462 -- Block => Bnn); 4463 -- parm := P.param; 4464 -- parm := P.param; 4465 -- ... 4466 -- end; 4467 4468 procedure Build_Simple_Entry_Call 4469 (N : Node_Id; 4470 Concval : Node_Id; 4471 Ename : Node_Id; 4472 Index : Node_Id) 4473 is 4474 begin 4475 Expand_Call (N); 4476 4477 -- If call has been inlined, nothing left to do 4478 4479 if Nkind (N) = N_Block_Statement then 4480 return; 4481 end if; 4482 4483 -- Convert entry call to Call_Simple call 4484 4485 declare 4486 Loc : constant Source_Ptr := Sloc (N); 4487 Parms : constant List_Id := Parameter_Associations (N); 4488 Stats : constant List_Id := New_List; 4489 Actual : Node_Id; 4490 Call : Node_Id; 4491 Comm_Name : Entity_Id; 4492 Conctyp : Node_Id; 4493 Decls : List_Id; 4494 Ent : Entity_Id; 4495 Ent_Acc : Entity_Id; 4496 Formal : Node_Id; 4497 Iface_Tag : Entity_Id; 4498 Iface_Typ : Entity_Id; 4499 N_Node : Node_Id; 4500 N_Var : Node_Id; 4501 P : Entity_Id; 4502 Parm1 : Node_Id; 4503 Parm2 : Node_Id; 4504 Parm3 : Node_Id; 4505 Pdecl : Node_Id; 4506 Plist : List_Id; 4507 X : Entity_Id; 4508 Xdecl : Node_Id; 4509 4510 begin 4511 -- Simple entry and entry family cases merge here 4512 4513 Ent := Entity (Ename); 4514 Ent_Acc := Entry_Parameters_Type (Ent); 4515 Conctyp := Etype (Concval); 4516 4517 -- If prefix is an access type, dereference to obtain the task type 4518 4519 if Is_Access_Type (Conctyp) then 4520 Conctyp := Designated_Type (Conctyp); 4521 end if; 4522 4523 -- Special case for protected subprogram calls 4524 4525 if Is_Protected_Type (Conctyp) 4526 and then Is_Subprogram (Entity (Ename)) 4527 then 4528 if not Is_Eliminated (Entity (Ename)) then 4529 Build_Protected_Subprogram_Call 4530 (N, Ename, Convert_Concurrent (Concval, Conctyp)); 4531 Analyze (N); 4532 end if; 4533 4534 return; 4535 end if; 4536 4537 -- First parameter is the Task_Id value from the task value or the 4538 -- Object from the protected object value, obtained by selecting 4539 -- the _Task_Id or _Object from the result of doing an unchecked 4540 -- conversion to convert the value to the corresponding record type. 4541 4542 if Nkind (Concval) = N_Function_Call 4543 and then Is_Task_Type (Conctyp) 4544 and then Ada_Version >= Ada_2005 4545 then 4546 declare 4547 ExpR : constant Node_Id := Relocate_Node (Concval); 4548 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR); 4549 Decl : Node_Id; 4550 4551 begin 4552 Decl := 4553 Make_Object_Declaration (Loc, 4554 Defining_Identifier => Obj, 4555 Object_Definition => New_Occurrence_Of (Conctyp, Loc), 4556 Expression => ExpR); 4557 Set_Etype (Obj, Conctyp); 4558 Decls := New_List (Decl); 4559 Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); 4560 end; 4561 4562 else 4563 Decls := New_List; 4564 end if; 4565 4566 Parm1 := Concurrent_Ref (Concval); 4567 4568 -- Second parameter is the entry index, computed by the routine 4569 -- provided for this purpose. The value of this expression is 4570 -- assigned to an intermediate variable to assure that any entry 4571 -- family index expressions are evaluated before the entry 4572 -- parameters. 4573 4574 if not Is_Protected_Type (Conctyp) 4575 or else 4576 Corresponding_Runtime_Package (Conctyp) = 4577 System_Tasking_Protected_Objects_Entries 4578 then 4579 X := Make_Defining_Identifier (Loc, Name_uX); 4580 4581 Xdecl := 4582 Make_Object_Declaration (Loc, 4583 Defining_Identifier => X, 4584 Object_Definition => 4585 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), 4586 Expression => Actual_Index_Expression ( 4587 Loc, Entity (Ename), Index, Concval)); 4588 4589 Append_To (Decls, Xdecl); 4590 Parm2 := New_Occurrence_Of (X, Loc); 4591 4592 else 4593 Xdecl := Empty; 4594 Parm2 := Empty; 4595 end if; 4596 4597 -- The third parameter is the packaged parameters. If there are 4598 -- none, then it is just the null address, since nothing is passed. 4599 4600 if No (Parms) then 4601 Parm3 := New_Occurrence_Of (RTE (RE_Null_Address), Loc); 4602 P := Empty; 4603 4604 -- Case of parameters present, where third argument is the address 4605 -- of a packaged record containing the required parameter values. 4606 4607 else 4608 -- First build a list of parameter values, which are references to 4609 -- objects of the parameter types. 4610 4611 Plist := New_List; 4612 4613 Actual := First_Actual (N); 4614 Formal := First_Formal (Ent); 4615 while Present (Actual) loop 4616 4617 -- If it is a by-copy type, copy it to a new variable. The 4618 -- packaged record has a field that points to this variable. 4619 4620 if Is_By_Copy_Type (Etype (Actual)) then 4621 N_Node := 4622 Make_Object_Declaration (Loc, 4623 Defining_Identifier => Make_Temporary (Loc, 'J'), 4624 Aliased_Present => True, 4625 Object_Definition => 4626 New_Occurrence_Of (Etype (Formal), Loc)); 4627 4628 -- Mark the object as not needing initialization since the 4629 -- initialization is performed separately, avoiding errors 4630 -- on cases such as formals of null-excluding access types. 4631 4632 Set_No_Initialization (N_Node); 4633 4634 -- We must make a separate assignment statement for the 4635 -- case of limited types. We cannot assign it unless the 4636 -- Assignment_OK flag is set first. An out formal of an 4637 -- access type or whose type has a Default_Value must also 4638 -- be initialized from the actual (see RM 6.4.1 (13-13.1)), 4639 -- but no constraint, predicate, or null-exclusion check is 4640 -- applied before the call. 4641 4642 if Ekind (Formal) /= E_Out_Parameter 4643 or else Is_Access_Type (Etype (Formal)) 4644 or else 4645 (Is_Scalar_Type (Etype (Formal)) 4646 and then 4647 Present (Default_Aspect_Value (Etype (Formal)))) 4648 then 4649 N_Var := 4650 New_Occurrence_Of (Defining_Identifier (N_Node), Loc); 4651 Set_Assignment_OK (N_Var); 4652 Append_To (Stats, 4653 Make_Assignment_Statement (Loc, 4654 Name => N_Var, 4655 Expression => Relocate_Node (Actual))); 4656 4657 -- Mark the object as internal, so we don't later reset 4658 -- No_Initialization flag in Default_Initialize_Object, 4659 -- which would lead to needless default initialization. 4660 -- We don't set this outside the if statement, because 4661 -- out scalar parameters without Default_Value do require 4662 -- default initialization if Initialize_Scalars applies. 4663 4664 Set_Is_Internal (Defining_Identifier (N_Node)); 4665 4666 -- If actual is an out parameter of a null-excluding 4667 -- access type, there is access check on entry, so set 4668 -- Suppress_Assignment_Checks on the generated statement 4669 -- that assigns the actual to the parameter block. 4670 4671 Set_Suppress_Assignment_Checks (Last (Stats)); 4672 end if; 4673 4674 Append (N_Node, Decls); 4675 4676 Append_To (Plist, 4677 Make_Attribute_Reference (Loc, 4678 Attribute_Name => Name_Unchecked_Access, 4679 Prefix => 4680 New_Occurrence_Of 4681 (Defining_Identifier (N_Node), Loc))); 4682 4683 else 4684 -- Interface class-wide formal 4685 4686 if Ada_Version >= Ada_2005 4687 and then Ekind (Etype (Formal)) = E_Class_Wide_Type 4688 and then Is_Interface (Etype (Formal)) 4689 then 4690 Iface_Typ := Etype (Etype (Formal)); 4691 4692 -- Generate: 4693 -- formal_iface_type! (actual.iface_tag)'reference 4694 4695 Iface_Tag := 4696 Find_Interface_Tag (Etype (Actual), Iface_Typ); 4697 pragma Assert (Present (Iface_Tag)); 4698 4699 Append_To (Plist, 4700 Make_Reference (Loc, 4701 Unchecked_Convert_To (Iface_Typ, 4702 Make_Selected_Component (Loc, 4703 Prefix => 4704 Relocate_Node (Actual), 4705 Selector_Name => 4706 New_Occurrence_Of (Iface_Tag, Loc))))); 4707 else 4708 -- Generate: 4709 -- actual'reference 4710 4711 Append_To (Plist, 4712 Make_Reference (Loc, Relocate_Node (Actual))); 4713 end if; 4714 end if; 4715 4716 Next_Actual (Actual); 4717 Next_Formal_With_Extras (Formal); 4718 end loop; 4719 4720 -- Now build the declaration of parameters initialized with the 4721 -- aggregate containing this constructed parameter list. 4722 4723 P := Make_Defining_Identifier (Loc, Name_uP); 4724 4725 Pdecl := 4726 Make_Object_Declaration (Loc, 4727 Defining_Identifier => P, 4728 Object_Definition => 4729 New_Occurrence_Of (Designated_Type (Ent_Acc), Loc), 4730 Expression => 4731 Make_Aggregate (Loc, Expressions => Plist)); 4732 4733 Parm3 := 4734 Make_Attribute_Reference (Loc, 4735 Prefix => New_Occurrence_Of (P, Loc), 4736 Attribute_Name => Name_Address); 4737 4738 Append (Pdecl, Decls); 4739 end if; 4740 4741 -- Now we can create the call, case of protected type 4742 4743 if Is_Protected_Type (Conctyp) then 4744 case Corresponding_Runtime_Package (Conctyp) is 4745 when System_Tasking_Protected_Objects_Entries => 4746 4747 -- Change the type of the index declaration 4748 4749 Set_Object_Definition (Xdecl, 4750 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)); 4751 4752 -- Some additional declarations for protected entry calls 4753 4754 if No (Decls) then 4755 Decls := New_List; 4756 end if; 4757 4758 -- Bnn : Communications_Block; 4759 4760 Comm_Name := Make_Temporary (Loc, 'B'); 4761 4762 Append_To (Decls, 4763 Make_Object_Declaration (Loc, 4764 Defining_Identifier => Comm_Name, 4765 Object_Definition => 4766 New_Occurrence_Of 4767 (RTE (RE_Communication_Block), Loc))); 4768 4769 -- Some additional statements for protected entry calls 4770 4771 -- Protected_Entry_Call 4772 -- (Object => po._object'Access, 4773 -- E => <entry index>; 4774 -- Uninterpreted_Data => P'Address; 4775 -- Mode => Simple_Call; 4776 -- Block => Bnn); 4777 4778 Call := 4779 Make_Procedure_Call_Statement (Loc, 4780 Name => 4781 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), 4782 4783 Parameter_Associations => New_List ( 4784 Make_Attribute_Reference (Loc, 4785 Attribute_Name => Name_Unchecked_Access, 4786 Prefix => Parm1), 4787 Parm2, 4788 Parm3, 4789 New_Occurrence_Of (RTE (RE_Simple_Call), Loc), 4790 New_Occurrence_Of (Comm_Name, Loc))); 4791 4792 when System_Tasking_Protected_Objects_Single_Entry => 4793 4794 -- Protected_Single_Entry_Call 4795 -- (Object => po._object'Access, 4796 -- Uninterpreted_Data => P'Address); 4797 4798 Call := 4799 Make_Procedure_Call_Statement (Loc, 4800 Name => 4801 New_Occurrence_Of 4802 (RTE (RE_Protected_Single_Entry_Call), Loc), 4803 4804 Parameter_Associations => New_List ( 4805 Make_Attribute_Reference (Loc, 4806 Attribute_Name => Name_Unchecked_Access, 4807 Prefix => Parm1), 4808 Parm3)); 4809 4810 when others => 4811 raise Program_Error; 4812 end case; 4813 4814 -- Case of task type 4815 4816 else 4817 Call := 4818 Make_Procedure_Call_Statement (Loc, 4819 Name => 4820 New_Occurrence_Of (RTE (RE_Call_Simple), Loc), 4821 Parameter_Associations => New_List (Parm1, Parm2, Parm3)); 4822 4823 end if; 4824 4825 Append_To (Stats, Call); 4826 4827 -- If there are out or in/out parameters by copy add assignment 4828 -- statements for the result values. 4829 4830 if Present (Parms) then 4831 Actual := First_Actual (N); 4832 Formal := First_Formal (Ent); 4833 4834 Set_Assignment_OK (Actual); 4835 while Present (Actual) loop 4836 if Is_By_Copy_Type (Etype (Actual)) 4837 and then Ekind (Formal) /= E_In_Parameter 4838 then 4839 N_Node := 4840 Make_Assignment_Statement (Loc, 4841 Name => New_Copy (Actual), 4842 Expression => 4843 Make_Explicit_Dereference (Loc, 4844 Make_Selected_Component (Loc, 4845 Prefix => New_Occurrence_Of (P, Loc), 4846 Selector_Name => 4847 Make_Identifier (Loc, Chars (Formal))))); 4848 4849 -- In all cases (including limited private types) we want 4850 -- the assignment to be valid. 4851 4852 Set_Assignment_OK (Name (N_Node)); 4853 4854 -- If the call is the triggering alternative in an 4855 -- asynchronous select, or the entry_call alternative of a 4856 -- conditional entry call, the assignments for in-out 4857 -- parameters are incorporated into the statement list that 4858 -- follows, so that there are executed only if the entry 4859 -- call succeeds. 4860 4861 if (Nkind (Parent (N)) = N_Triggering_Alternative 4862 and then N = Triggering_Statement (Parent (N))) 4863 or else 4864 (Nkind (Parent (N)) = N_Entry_Call_Alternative 4865 and then N = Entry_Call_Statement (Parent (N))) 4866 then 4867 if No (Statements (Parent (N))) then 4868 Set_Statements (Parent (N), New_List); 4869 end if; 4870 4871 Prepend (N_Node, Statements (Parent (N))); 4872 4873 else 4874 Insert_After (Call, N_Node); 4875 end if; 4876 end if; 4877 4878 Next_Actual (Actual); 4879 Next_Formal_With_Extras (Formal); 4880 end loop; 4881 end if; 4882 4883 -- Finally, create block and analyze it 4884 4885 Rewrite (N, 4886 Make_Block_Statement (Loc, 4887 Declarations => Decls, 4888 Handled_Statement_Sequence => 4889 Make_Handled_Sequence_Of_Statements (Loc, 4890 Statements => Stats))); 4891 4892 Analyze (N); 4893 end; 4894 end Build_Simple_Entry_Call; 4895 4896 -------------------------------- 4897 -- Build_Task_Activation_Call -- 4898 -------------------------------- 4899 4900 procedure Build_Task_Activation_Call (N : Node_Id) is 4901 function Activation_Call_Loc return Source_Ptr; 4902 -- Find a suitable source location for the activation call 4903 4904 ------------------------- 4905 -- Activation_Call_Loc -- 4906 ------------------------- 4907 4908 function Activation_Call_Loc return Source_Ptr is 4909 begin 4910 -- The activation call must carry the location of the "end" keyword 4911 -- when the context is a package declaration. 4912 4913 if Nkind (N) = N_Package_Declaration then 4914 return End_Keyword_Location (N); 4915 4916 -- Otherwise the activation call must carry the location of the 4917 -- "begin" keyword. 4918 4919 else 4920 return Begin_Keyword_Location (N); 4921 end if; 4922 end Activation_Call_Loc; 4923 4924 -- Local variables 4925 4926 Chain : Entity_Id; 4927 Call : Node_Id; 4928 Loc : Source_Ptr; 4929 Name : Node_Id; 4930 Owner : Node_Id; 4931 Stmt : Node_Id; 4932 4933 -- Start of processing for Build_Task_Activation_Call 4934 4935 begin 4936 -- For sequential elaboration policy, all the tasks will be activated at 4937 -- the end of the elaboration. 4938 4939 if Partition_Elaboration_Policy = 'S' then 4940 return; 4941 4942 -- Do not create an activation call for a package spec if the package 4943 -- has a completing body. The activation call will be inserted after 4944 -- the "begin" of the body. 4945 4946 elsif Nkind (N) = N_Package_Declaration 4947 and then Present (Corresponding_Body (N)) 4948 then 4949 return; 4950 end if; 4951 4952 -- Obtain the activation chain entity. Block statements, entry bodies, 4953 -- subprogram bodies, and task bodies keep the entity in their nodes. 4954 -- Package bodies on the other hand store it in the declaration of the 4955 -- corresponding package spec. 4956 4957 Owner := N; 4958 4959 if Nkind (Owner) = N_Package_Body then 4960 Owner := Unit_Declaration_Node (Corresponding_Spec (Owner)); 4961 end if; 4962 4963 Chain := Activation_Chain_Entity (Owner); 4964 4965 -- Nothing to do when there are no tasks to activate. This is indicated 4966 -- by a missing activation chain entity. 4967 4968 if No (Chain) then 4969 return; 4970 end if; 4971 4972 -- The location of the activation call must be as close as possible to 4973 -- the intended semantic location of the activation because the ABE 4974 -- mechanism relies heavily on accurate locations. 4975 4976 Loc := Activation_Call_Loc; 4977 4978 if Restricted_Profile then 4979 Name := New_Occurrence_Of (RTE (RE_Activate_Restricted_Tasks), Loc); 4980 else 4981 Name := New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc); 4982 end if; 4983 4984 Call := 4985 Make_Procedure_Call_Statement (Loc, 4986 Name => Name, 4987 Parameter_Associations => 4988 New_List (Make_Attribute_Reference (Loc, 4989 Prefix => New_Occurrence_Of (Chain, Loc), 4990 Attribute_Name => Name_Unchecked_Access))); 4991 4992 if Nkind (N) = N_Package_Declaration then 4993 if Present (Private_Declarations (Specification (N))) then 4994 Append (Call, Private_Declarations (Specification (N))); 4995 else 4996 Append (Call, Visible_Declarations (Specification (N))); 4997 end if; 4998 4999 else 5000 -- The call goes at the start of the statement sequence after the 5001 -- start of exception range label if one is present. 5002 5003 if Present (Handled_Statement_Sequence (N)) then 5004 Stmt := First (Statements (Handled_Statement_Sequence (N))); 5005 5006 -- A special case, skip exception range label if one is present 5007 -- (from front end zcx processing). 5008 5009 if Nkind (Stmt) = N_Label and then Exception_Junk (Stmt) then 5010 Next (Stmt); 5011 end if; 5012 5013 -- Another special case, if the first statement is a block from 5014 -- optimization of a local raise to a goto, then the call goes 5015 -- inside this block. 5016 5017 if Nkind (Stmt) = N_Block_Statement 5018 and then Exception_Junk (Stmt) 5019 then 5020 Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); 5021 end if; 5022 5023 -- Insertion point is after any exception label pushes, since we 5024 -- want it covered by any local handlers. 5025 5026 while Nkind (Stmt) in N_Push_xxx_Label loop 5027 Next (Stmt); 5028 end loop; 5029 5030 -- Now we have the proper insertion point 5031 5032 Insert_Before (Stmt, Call); 5033 5034 else 5035 Set_Handled_Statement_Sequence (N, 5036 Make_Handled_Sequence_Of_Statements (Loc, 5037 Statements => New_List (Call))); 5038 end if; 5039 end if; 5040 5041 Analyze (Call); 5042 5043 if Legacy_Elaboration_Checks then 5044 Check_Task_Activation (N); 5045 end if; 5046 end Build_Task_Activation_Call; 5047 5048 ------------------------------- 5049 -- Build_Task_Allocate_Block -- 5050 ------------------------------- 5051 5052 procedure Build_Task_Allocate_Block 5053 (Actions : List_Id; 5054 N : Node_Id; 5055 Args : List_Id) 5056 is 5057 T : constant Entity_Id := Entity (Expression (N)); 5058 Init : constant Entity_Id := Base_Init_Proc (T); 5059 Loc : constant Source_Ptr := Sloc (N); 5060 Chain : constant Entity_Id := 5061 Make_Defining_Identifier (Loc, Name_uChain); 5062 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 5063 Block : Node_Id; 5064 5065 begin 5066 Block := 5067 Make_Block_Statement (Loc, 5068 Identifier => New_Occurrence_Of (Blkent, Loc), 5069 Declarations => New_List ( 5070 5071 -- _Chain : Activation_Chain; 5072 5073 Make_Object_Declaration (Loc, 5074 Defining_Identifier => Chain, 5075 Aliased_Present => True, 5076 Object_Definition => 5077 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5078 5079 Handled_Statement_Sequence => 5080 Make_Handled_Sequence_Of_Statements (Loc, 5081 5082 Statements => New_List ( 5083 5084 -- Init (Args); 5085 5086 Make_Procedure_Call_Statement (Loc, 5087 Name => New_Occurrence_Of (Init, Loc), 5088 Parameter_Associations => Args), 5089 5090 -- Activate_Tasks (_Chain); 5091 5092 Make_Procedure_Call_Statement (Loc, 5093 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 5094 Parameter_Associations => New_List ( 5095 Make_Attribute_Reference (Loc, 5096 Prefix => New_Occurrence_Of (Chain, Loc), 5097 Attribute_Name => Name_Unchecked_Access))))), 5098 5099 Has_Created_Identifier => True, 5100 Is_Task_Allocation_Block => True); 5101 5102 Append_To (Actions, 5103 Make_Implicit_Label_Declaration (Loc, 5104 Defining_Identifier => Blkent, 5105 Label_Construct => Block)); 5106 5107 Append_To (Actions, Block); 5108 5109 Set_Activation_Chain_Entity (Block, Chain); 5110 end Build_Task_Allocate_Block; 5111 5112 ----------------------------------------------- 5113 -- Build_Task_Allocate_Block_With_Init_Stmts -- 5114 ----------------------------------------------- 5115 5116 procedure Build_Task_Allocate_Block_With_Init_Stmts 5117 (Actions : List_Id; 5118 N : Node_Id; 5119 Init_Stmts : List_Id) 5120 is 5121 Loc : constant Source_Ptr := Sloc (N); 5122 Chain : constant Entity_Id := 5123 Make_Defining_Identifier (Loc, Name_uChain); 5124 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 5125 Block : Node_Id; 5126 5127 begin 5128 Append_To (Init_Stmts, 5129 Make_Procedure_Call_Statement (Loc, 5130 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 5131 Parameter_Associations => New_List ( 5132 Make_Attribute_Reference (Loc, 5133 Prefix => New_Occurrence_Of (Chain, Loc), 5134 Attribute_Name => Name_Unchecked_Access)))); 5135 5136 Block := 5137 Make_Block_Statement (Loc, 5138 Identifier => New_Occurrence_Of (Blkent, Loc), 5139 Declarations => New_List ( 5140 5141 -- _Chain : Activation_Chain; 5142 5143 Make_Object_Declaration (Loc, 5144 Defining_Identifier => Chain, 5145 Aliased_Present => True, 5146 Object_Definition => 5147 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5148 5149 Handled_Statement_Sequence => 5150 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts), 5151 5152 Has_Created_Identifier => True, 5153 Is_Task_Allocation_Block => True); 5154 5155 Append_To (Actions, 5156 Make_Implicit_Label_Declaration (Loc, 5157 Defining_Identifier => Blkent, 5158 Label_Construct => Block)); 5159 5160 Append_To (Actions, Block); 5161 5162 Set_Activation_Chain_Entity (Block, Chain); 5163 end Build_Task_Allocate_Block_With_Init_Stmts; 5164 5165 ----------------------------------- 5166 -- Build_Task_Proc_Specification -- 5167 ----------------------------------- 5168 5169 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is 5170 Loc : constant Source_Ptr := Sloc (T); 5171 Spec_Id : Entity_Id; 5172 5173 begin 5174 -- Case of explicit task type, suffix TB 5175 5176 if Comes_From_Source (T) then 5177 Spec_Id := 5178 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB")); 5179 5180 -- Case of anonymous task type, suffix B 5181 5182 else 5183 Spec_Id := 5184 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B')); 5185 end if; 5186 5187 Set_Is_Internal (Spec_Id); 5188 5189 -- Associate the procedure with the task, if this is the declaration 5190 -- (and not the body) of the procedure. 5191 5192 if No (Task_Body_Procedure (T)) then 5193 Set_Task_Body_Procedure (T, Spec_Id); 5194 end if; 5195 5196 return 5197 Make_Procedure_Specification (Loc, 5198 Defining_Unit_Name => Spec_Id, 5199 Parameter_Specifications => New_List ( 5200 Make_Parameter_Specification (Loc, 5201 Defining_Identifier => 5202 Make_Defining_Identifier (Loc, Name_uTask), 5203 Parameter_Type => 5204 Make_Access_Definition (Loc, 5205 Subtype_Mark => 5206 New_Occurrence_Of (Corresponding_Record_Type (T), Loc))))); 5207 end Build_Task_Proc_Specification; 5208 5209 --------------------------------------- 5210 -- Build_Unprotected_Subprogram_Body -- 5211 --------------------------------------- 5212 5213 function Build_Unprotected_Subprogram_Body 5214 (N : Node_Id; 5215 Pid : Node_Id) return Node_Id 5216 is 5217 Decls : constant List_Id := Declarations (N); 5218 5219 begin 5220 -- Add renamings for the Protection object, discriminals, privals, and 5221 -- the entry index constant for use by debugger. 5222 5223 Debug_Private_Data_Declarations (Decls); 5224 5225 -- Make an unprotected version of the subprogram for use within the same 5226 -- object, with a new name and an additional parameter representing the 5227 -- object. 5228 5229 return 5230 Make_Subprogram_Body (Sloc (N), 5231 Specification => 5232 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), 5233 Declarations => Decls, 5234 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 5235 end Build_Unprotected_Subprogram_Body; 5236 5237 ---------------------------- 5238 -- Collect_Entry_Families -- 5239 ---------------------------- 5240 5241 procedure Collect_Entry_Families 5242 (Loc : Source_Ptr; 5243 Cdecls : List_Id; 5244 Current_Node : in out Node_Id; 5245 Conctyp : Entity_Id) 5246 is 5247 Efam : Entity_Id; 5248 Efam_Decl : Node_Id; 5249 Efam_Type : Entity_Id; 5250 5251 begin 5252 Efam := First_Entity (Conctyp); 5253 while Present (Efam) loop 5254 if Ekind (Efam) = E_Entry_Family then 5255 Efam_Type := Make_Temporary (Loc, 'F'); 5256 5257 declare 5258 Bas : Entity_Id := 5259 Base_Type 5260 (Etype (Discrete_Subtype_Definition (Parent (Efam)))); 5261 5262 Bas_Decl : Node_Id := Empty; 5263 Lo, Hi : Node_Id; 5264 5265 begin 5266 Get_Index_Bounds 5267 (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi); 5268 5269 if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then 5270 Bas := Make_Temporary (Loc, 'B'); 5271 5272 Bas_Decl := 5273 Make_Subtype_Declaration (Loc, 5274 Defining_Identifier => Bas, 5275 Subtype_Indication => 5276 Make_Subtype_Indication (Loc, 5277 Subtype_Mark => 5278 New_Occurrence_Of (Standard_Integer, Loc), 5279 Constraint => 5280 Make_Range_Constraint (Loc, 5281 Range_Expression => Make_Range (Loc, 5282 Make_Integer_Literal 5283 (Loc, -Entry_Family_Bound), 5284 Make_Integer_Literal 5285 (Loc, Entry_Family_Bound - 1))))); 5286 5287 Insert_After (Current_Node, Bas_Decl); 5288 Current_Node := Bas_Decl; 5289 Analyze (Bas_Decl); 5290 end if; 5291 5292 Efam_Decl := 5293 Make_Full_Type_Declaration (Loc, 5294 Defining_Identifier => Efam_Type, 5295 Type_Definition => 5296 Make_Unconstrained_Array_Definition (Loc, 5297 Subtype_Marks => 5298 (New_List (New_Occurrence_Of (Bas, Loc))), 5299 5300 Component_Definition => 5301 Make_Component_Definition (Loc, 5302 Aliased_Present => False, 5303 Subtype_Indication => 5304 New_Occurrence_Of (Standard_Character, Loc)))); 5305 end; 5306 5307 Insert_After (Current_Node, Efam_Decl); 5308 Current_Node := Efam_Decl; 5309 Analyze (Efam_Decl); 5310 5311 Append_To (Cdecls, 5312 Make_Component_Declaration (Loc, 5313 Defining_Identifier => 5314 Make_Defining_Identifier (Loc, Chars (Efam)), 5315 5316 Component_Definition => 5317 Make_Component_Definition (Loc, 5318 Aliased_Present => False, 5319 Subtype_Indication => 5320 Make_Subtype_Indication (Loc, 5321 Subtype_Mark => 5322 New_Occurrence_Of (Efam_Type, Loc), 5323 5324 Constraint => 5325 Make_Index_Or_Discriminant_Constraint (Loc, 5326 Constraints => New_List ( 5327 New_Occurrence_Of 5328 (Etype (Discrete_Subtype_Definition 5329 (Parent (Efam))), Loc))))))); 5330 5331 end if; 5332 5333 Next_Entity (Efam); 5334 end loop; 5335 end Collect_Entry_Families; 5336 5337 ----------------------- 5338 -- Concurrent_Object -- 5339 ----------------------- 5340 5341 function Concurrent_Object 5342 (Spec_Id : Entity_Id; 5343 Conc_Typ : Entity_Id) return Entity_Id 5344 is 5345 begin 5346 -- Parameter _O or _object 5347 5348 if Is_Protected_Type (Conc_Typ) then 5349 return First_Formal (Protected_Body_Subprogram (Spec_Id)); 5350 5351 -- Parameter _task 5352 5353 else 5354 pragma Assert (Is_Task_Type (Conc_Typ)); 5355 return First_Formal (Task_Body_Procedure (Conc_Typ)); 5356 end if; 5357 end Concurrent_Object; 5358 5359 ---------------------- 5360 -- Copy_Result_Type -- 5361 ---------------------- 5362 5363 function Copy_Result_Type (Res : Node_Id) return Node_Id is 5364 New_Res : constant Node_Id := New_Copy_Tree (Res); 5365 Par_Spec : Node_Id; 5366 Formal : Entity_Id; 5367 5368 begin 5369 -- If the result type is an access_to_subprogram, we must create new 5370 -- entities for its spec. 5371 5372 if Nkind (New_Res) = N_Access_Definition 5373 and then Present (Access_To_Subprogram_Definition (New_Res)) 5374 then 5375 -- Provide new entities for the formals 5376 5377 Par_Spec := First (Parameter_Specifications 5378 (Access_To_Subprogram_Definition (New_Res))); 5379 while Present (Par_Spec) loop 5380 Formal := Defining_Identifier (Par_Spec); 5381 Set_Defining_Identifier (Par_Spec, 5382 Make_Defining_Identifier (Sloc (Formal), Chars (Formal))); 5383 Next (Par_Spec); 5384 end loop; 5385 end if; 5386 5387 return New_Res; 5388 end Copy_Result_Type; 5389 5390 -------------------- 5391 -- Concurrent_Ref -- 5392 -------------------- 5393 5394 -- The expression returned for a reference to a concurrent object has the 5395 -- form: 5396 5397 -- taskV!(name)._Task_Id 5398 5399 -- for a task, and 5400 5401 -- objectV!(name)._Object 5402 5403 -- for a protected object. For the case of an access to a concurrent 5404 -- object, there is an extra explicit dereference: 5405 5406 -- taskV!(name.all)._Task_Id 5407 -- objectV!(name.all)._Object 5408 5409 -- here taskV and objectV are the types for the associated records, which 5410 -- contain the required _Task_Id and _Object fields for tasks and protected 5411 -- objects, respectively. 5412 5413 -- For the case of a task type name, the expression is 5414 5415 -- Self; 5416 5417 -- i.e. a call to the Self function which returns precisely this Task_Id 5418 5419 -- For the case of a protected type name, the expression is 5420 5421 -- objectR 5422 5423 -- which is a renaming of the _object field of the current object 5424 -- record, passed into protected operations as a parameter. 5425 5426 function Concurrent_Ref (N : Node_Id) return Node_Id is 5427 Loc : constant Source_Ptr := Sloc (N); 5428 Ntyp : constant Entity_Id := Etype (N); 5429 Dtyp : Entity_Id; 5430 Sel : Name_Id; 5431 5432 function Is_Current_Task (T : Entity_Id) return Boolean; 5433 -- Check whether the reference is to the immediately enclosing task 5434 -- type, or to an outer one (rare but legal). 5435 5436 --------------------- 5437 -- Is_Current_Task -- 5438 --------------------- 5439 5440 function Is_Current_Task (T : Entity_Id) return Boolean is 5441 Scop : Entity_Id; 5442 5443 begin 5444 Scop := Current_Scope; 5445 while Present (Scop) and then Scop /= Standard_Standard loop 5446 if Scop = T then 5447 return True; 5448 5449 elsif Is_Task_Type (Scop) then 5450 return False; 5451 5452 -- If this is a procedure nested within the task type, we must 5453 -- assume that it can be called from an inner task, and therefore 5454 -- cannot treat it as a local reference. 5455 5456 elsif Is_Overloadable (Scop) and then In_Open_Scopes (T) then 5457 return False; 5458 5459 else 5460 Scop := Scope (Scop); 5461 end if; 5462 end loop; 5463 5464 -- We know that we are within the task body, so should have found it 5465 -- in scope. 5466 5467 raise Program_Error; 5468 end Is_Current_Task; 5469 5470 -- Start of processing for Concurrent_Ref 5471 5472 begin 5473 if Is_Access_Type (Ntyp) then 5474 Dtyp := Designated_Type (Ntyp); 5475 5476 if Is_Protected_Type (Dtyp) then 5477 Sel := Name_uObject; 5478 else 5479 Sel := Name_uTask_Id; 5480 end if; 5481 5482 return 5483 Make_Selected_Component (Loc, 5484 Prefix => 5485 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp), 5486 Make_Explicit_Dereference (Loc, N)), 5487 Selector_Name => Make_Identifier (Loc, Sel)); 5488 5489 elsif Is_Entity_Name (N) and then Is_Concurrent_Type (Entity (N)) then 5490 if Is_Task_Type (Entity (N)) then 5491 5492 if Is_Current_Task (Entity (N)) then 5493 return 5494 Make_Function_Call (Loc, 5495 Name => New_Occurrence_Of (RTE (RE_Self), Loc)); 5496 5497 else 5498 declare 5499 Decl : Node_Id; 5500 T_Self : constant Entity_Id := Make_Temporary (Loc, 'T'); 5501 T_Body : constant Node_Id := 5502 Parent (Corresponding_Body (Parent (Entity (N)))); 5503 5504 begin 5505 Decl := 5506 Make_Object_Declaration (Loc, 5507 Defining_Identifier => T_Self, 5508 Object_Definition => 5509 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 5510 Expression => 5511 Make_Function_Call (Loc, 5512 Name => New_Occurrence_Of (RTE (RE_Self), Loc))); 5513 Prepend (Decl, Declarations (T_Body)); 5514 Analyze (Decl); 5515 Set_Scope (T_Self, Entity (N)); 5516 return New_Occurrence_Of (T_Self, Loc); 5517 end; 5518 end if; 5519 5520 else 5521 pragma Assert (Is_Protected_Type (Entity (N))); 5522 5523 return 5524 New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc); 5525 end if; 5526 5527 else 5528 if Is_Protected_Type (Ntyp) then 5529 Sel := Name_uObject; 5530 elsif Is_Task_Type (Ntyp) then 5531 Sel := Name_uTask_Id; 5532 else 5533 raise Program_Error; 5534 end if; 5535 5536 return 5537 Make_Selected_Component (Loc, 5538 Prefix => 5539 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp), 5540 New_Copy_Tree (N)), 5541 Selector_Name => Make_Identifier (Loc, Sel)); 5542 end if; 5543 end Concurrent_Ref; 5544 5545 ------------------------ 5546 -- Convert_Concurrent -- 5547 ------------------------ 5548 5549 function Convert_Concurrent 5550 (N : Node_Id; 5551 Typ : Entity_Id) return Node_Id 5552 is 5553 begin 5554 if not Is_Concurrent_Type (Typ) then 5555 return N; 5556 else 5557 return 5558 Unchecked_Convert_To 5559 (Corresponding_Record_Type (Typ), New_Copy_Tree (N)); 5560 end if; 5561 end Convert_Concurrent; 5562 5563 ------------------------------------- 5564 -- Create_Secondary_Stack_For_Task -- 5565 ------------------------------------- 5566 5567 function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean is 5568 begin 5569 return 5570 (Restriction_Active (No_Implicit_Heap_Allocations) 5571 or else Restriction_Active (No_Implicit_Task_Allocations)) 5572 and then not Restriction_Active (No_Secondary_Stack) 5573 and then Has_Rep_Pragma 5574 (T, Name_Secondary_Stack_Size, Check_Parents => False); 5575 end Create_Secondary_Stack_For_Task; 5576 5577 ------------------------------------- 5578 -- Debug_Private_Data_Declarations -- 5579 ------------------------------------- 5580 5581 procedure Debug_Private_Data_Declarations (Decls : List_Id) is 5582 Debug_Nod : Node_Id; 5583 Decl : Node_Id; 5584 5585 begin 5586 Decl := First (Decls); 5587 while Present (Decl) and then not Comes_From_Source (Decl) loop 5588 5589 -- Declaration for concurrent entity _object and its access type, 5590 -- along with the entry index subtype: 5591 -- type prot_typVP is access prot_typV; 5592 -- _object : prot_typVP := prot_typV (_O); 5593 -- subtype Jnn is <Type of Index> range Low .. High; 5594 5595 if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then 5596 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5597 5598 -- Declaration for the Protection object, discriminals, privals, and 5599 -- entry index constant: 5600 -- conc_typR : protection_typ renames _object._object; 5601 -- discr_nameD : discr_typ renames _object.discr_name; 5602 -- discr_nameD : discr_typ renames _task.discr_name; 5603 -- prival_name : comp_typ renames _object.comp_name; 5604 -- J : constant Jnn := 5605 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First)); 5606 5607 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 5608 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5609 Debug_Nod := Debug_Renaming_Declaration (Decl); 5610 5611 if Present (Debug_Nod) then 5612 Insert_After (Decl, Debug_Nod); 5613 end if; 5614 end if; 5615 5616 Next (Decl); 5617 end loop; 5618 end Debug_Private_Data_Declarations; 5619 5620 ------------------------------ 5621 -- Ensure_Statement_Present -- 5622 ------------------------------ 5623 5624 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is 5625 Stmt : Node_Id; 5626 5627 begin 5628 if Opt.Suppress_Control_Flow_Optimizations 5629 and then Is_Empty_List (Statements (Alt)) 5630 then 5631 Stmt := Make_Null_Statement (Loc); 5632 5633 -- Mark NULL statement as coming from source so that it is not 5634 -- eliminated by GIGI. 5635 5636 -- Another covert channel. If this is a requirement, it must be 5637 -- documented in sinfo/einfo ??? 5638 5639 Set_Comes_From_Source (Stmt, True); 5640 5641 Set_Statements (Alt, New_List (Stmt)); 5642 end if; 5643 end Ensure_Statement_Present; 5644 5645 ---------------------------- 5646 -- Entry_Index_Expression -- 5647 ---------------------------- 5648 5649 function Entry_Index_Expression 5650 (Sloc : Source_Ptr; 5651 Ent : Entity_Id; 5652 Index : Node_Id; 5653 Ttyp : Entity_Id) return Node_Id 5654 is 5655 Expr : Node_Id; 5656 Num : Node_Id; 5657 Lo : Node_Id; 5658 Hi : Node_Id; 5659 Prev : Entity_Id; 5660 S : Node_Id; 5661 5662 begin 5663 -- The queues of entries and entry families appear in textual order in 5664 -- the associated record. The entry index is computed as the sum of the 5665 -- number of queues for all entries that precede the designated one, to 5666 -- which is added the index expression, if this expression denotes a 5667 -- member of a family. 5668 5669 -- The following is a place holder for the count of simple entries 5670 5671 Num := Make_Integer_Literal (Sloc, 1); 5672 5673 -- We construct an expression which is a series of addition operations. 5674 -- The first operand is the number of single entries that precede this 5675 -- one, the second operand is the index value relative to the start of 5676 -- the referenced family, and the remaining operands are the lengths of 5677 -- the entry families that precede this entry, i.e. the constructed 5678 -- expression is: 5679 5680 -- number_simple_entries + 5681 -- (s'pos (index-value) - s'pos (family'first)) + 1 + 5682 -- family'length + ... 5683 5684 -- where index-value is the given index value, and s is the index 5685 -- subtype (we have to use pos because the subtype might be an 5686 -- enumeration type preventing direct subtraction). Note that the task 5687 -- entry array is one-indexed. 5688 5689 -- The upper bound of the entry family may be a discriminant, so we 5690 -- retrieve the lower bound explicitly to compute offset, rather than 5691 -- using the index subtype which may mention a discriminant. 5692 5693 if Present (Index) then 5694 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); 5695 5696 Expr := 5697 Make_Op_Add (Sloc, 5698 Left_Opnd => Num, 5699 Right_Opnd => 5700 Family_Offset 5701 (Sloc, 5702 Make_Attribute_Reference (Sloc, 5703 Attribute_Name => Name_Pos, 5704 Prefix => New_Occurrence_Of (Base_Type (S), Sloc), 5705 Expressions => New_List (Relocate_Node (Index))), 5706 Type_Low_Bound (S), 5707 Ttyp, 5708 False)); 5709 else 5710 Expr := Num; 5711 end if; 5712 5713 -- Now add lengths of preceding entries and entry families 5714 5715 Prev := First_Entity (Ttyp); 5716 while Chars (Prev) /= Chars (Ent) 5717 or else (Ekind (Prev) /= Ekind (Ent)) 5718 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 5719 loop 5720 if Ekind (Prev) = E_Entry then 5721 Set_Intval (Num, Intval (Num) + 1); 5722 5723 elsif Ekind (Prev) = E_Entry_Family then 5724 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 5725 Lo := Type_Low_Bound (S); 5726 Hi := Type_High_Bound (S); 5727 5728 Expr := 5729 Make_Op_Add (Sloc, 5730 Left_Opnd => Expr, 5731 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False)); 5732 5733 -- Other components are anonymous types to be ignored 5734 5735 else 5736 null; 5737 end if; 5738 5739 Next_Entity (Prev); 5740 end loop; 5741 5742 return Expr; 5743 end Entry_Index_Expression; 5744 5745 --------------------------- 5746 -- Establish_Task_Master -- 5747 --------------------------- 5748 5749 procedure Establish_Task_Master (N : Node_Id) is 5750 Call : Node_Id; 5751 5752 begin 5753 if Restriction_Active (No_Task_Hierarchy) = False then 5754 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); 5755 5756 -- The block may have no declarations (and nevertheless be a task 5757 -- master) if it contains a call that may return an object that 5758 -- contains tasks. 5759 5760 if No (Declarations (N)) then 5761 Set_Declarations (N, New_List (Call)); 5762 else 5763 Prepend_To (Declarations (N), Call); 5764 end if; 5765 5766 Analyze (Call); 5767 end if; 5768 end Establish_Task_Master; 5769 5770 -------------------------------- 5771 -- Expand_Accept_Declarations -- 5772 -------------------------------- 5773 5774 -- Part of the expansion of an accept statement involves the creation of 5775 -- a declaration that can be referenced from the statement sequence of 5776 -- the accept: 5777 5778 -- Ann : Address; 5779 5780 -- This declaration is inserted immediately before the accept statement 5781 -- and it is important that it be inserted before the statements of the 5782 -- statement sequence are analyzed. Thus it would be too late to create 5783 -- this declaration in the Expand_N_Accept_Statement routine, which is 5784 -- why there is a separate procedure to be called directly from Sem_Ch9. 5785 5786 -- Ann is used to hold the address of the record containing the parameters 5787 -- (see Expand_N_Entry_Call for more details on how this record is built). 5788 -- References to the parameters do an unchecked conversion of this address 5789 -- to a pointer to the required record type, and then access the field that 5790 -- holds the value of the required parameter. The entity for the address 5791 -- variable is held as the top stack element (i.e. the last element) of the 5792 -- Accept_Address stack in the corresponding entry entity, and this element 5793 -- must be set in place before the statements are processed. 5794 5795 -- The above description applies to the case of a stand alone accept 5796 -- statement, i.e. one not appearing as part of a select alternative. 5797 5798 -- For the case of an accept that appears as part of a select alternative 5799 -- of a selective accept, we must still create the declaration right away, 5800 -- since Ann is needed immediately, but there is an important difference: 5801 5802 -- The declaration is inserted before the selective accept, not before 5803 -- the accept statement (which is not part of a list anyway, and so would 5804 -- not accommodate inserted declarations) 5805 5806 -- We only need one address variable for the entire selective accept. So 5807 -- the Ann declaration is created only for the first accept alternative, 5808 -- and subsequent accept alternatives reference the same Ann variable. 5809 5810 -- We can distinguish the two cases by seeing whether the accept statement 5811 -- is part of a list. If not, then it must be in an accept alternative. 5812 5813 -- To expand the requeue statement, a label is provided at the end of the 5814 -- accept statement or alternative of which it is a part, so that the 5815 -- statement can be skipped after the requeue is complete. This label is 5816 -- created here rather than during the expansion of the accept statement, 5817 -- because it will be needed by any requeue statements within the accept, 5818 -- which are expanded before the accept. 5819 5820 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is 5821 Loc : constant Source_Ptr := Sloc (N); 5822 Stats : constant Node_Id := Handled_Statement_Sequence (N); 5823 Ann : Entity_Id := Empty; 5824 Adecl : Node_Id; 5825 Lab : Node_Id; 5826 Ldecl : Node_Id; 5827 Ldecl2 : Node_Id; 5828 5829 begin 5830 if Expander_Active then 5831 5832 -- If we have no handled statement sequence, we may need to build 5833 -- a dummy sequence consisting of a null statement. This can be 5834 -- skipped if the trivial accept optimization is permitted. 5835 5836 if not Trivial_Accept_OK 5837 and then (No (Stats) or else Null_Statements (Statements (Stats))) 5838 then 5839 Set_Handled_Statement_Sequence (N, 5840 Make_Handled_Sequence_Of_Statements (Loc, 5841 Statements => New_List (Make_Null_Statement (Loc)))); 5842 end if; 5843 5844 -- Create and declare two labels to be placed at the end of the 5845 -- accept statement. The first label is used to allow requeues to 5846 -- skip the remainder of entry processing. The second label is used 5847 -- to skip the remainder of entry processing if the rendezvous 5848 -- completes in the middle of the accept body. 5849 5850 if Present (Handled_Statement_Sequence (N)) then 5851 declare 5852 Ent : Entity_Id; 5853 5854 begin 5855 Ent := Make_Temporary (Loc, 'L'); 5856 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 5857 Ldecl := 5858 Make_Implicit_Label_Declaration (Loc, 5859 Defining_Identifier => Ent, 5860 Label_Construct => Lab); 5861 Append (Lab, Statements (Handled_Statement_Sequence (N))); 5862 5863 Ent := Make_Temporary (Loc, 'L'); 5864 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 5865 Ldecl2 := 5866 Make_Implicit_Label_Declaration (Loc, 5867 Defining_Identifier => Ent, 5868 Label_Construct => Lab); 5869 Append (Lab, Statements (Handled_Statement_Sequence (N))); 5870 end; 5871 5872 else 5873 Ldecl := Empty; 5874 Ldecl2 := Empty; 5875 end if; 5876 5877 -- Case of stand alone accept statement 5878 5879 if Is_List_Member (N) then 5880 5881 if Present (Handled_Statement_Sequence (N)) then 5882 Ann := Make_Temporary (Loc, 'A'); 5883 5884 Adecl := 5885 Make_Object_Declaration (Loc, 5886 Defining_Identifier => Ann, 5887 Object_Definition => 5888 New_Occurrence_Of (RTE (RE_Address), Loc)); 5889 5890 Insert_Before_And_Analyze (N, Adecl); 5891 Insert_Before_And_Analyze (N, Ldecl); 5892 Insert_Before_And_Analyze (N, Ldecl2); 5893 end if; 5894 5895 -- Case of accept statement which is in an accept alternative 5896 5897 else 5898 declare 5899 Acc_Alt : constant Node_Id := Parent (N); 5900 Sel_Acc : constant Node_Id := Parent (Acc_Alt); 5901 Alt : Node_Id; 5902 5903 begin 5904 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative); 5905 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept); 5906 5907 -- ??? Consider a single label for select statements 5908 5909 if Present (Handled_Statement_Sequence (N)) then 5910 Prepend (Ldecl2, 5911 Statements (Handled_Statement_Sequence (N))); 5912 Analyze (Ldecl2); 5913 5914 Prepend (Ldecl, 5915 Statements (Handled_Statement_Sequence (N))); 5916 Analyze (Ldecl); 5917 end if; 5918 5919 -- Find first accept alternative of the selective accept. A 5920 -- valid selective accept must have at least one accept in it. 5921 5922 Alt := First (Select_Alternatives (Sel_Acc)); 5923 5924 while Nkind (Alt) /= N_Accept_Alternative loop 5925 Next (Alt); 5926 end loop; 5927 5928 -- If this is the first accept statement, then we have to 5929 -- create the Ann variable, as for the stand alone case, except 5930 -- that it is inserted before the selective accept. Similarly, 5931 -- a label for requeue expansion must be declared. 5932 5933 if N = Accept_Statement (Alt) then 5934 Ann := Make_Temporary (Loc, 'A'); 5935 Adecl := 5936 Make_Object_Declaration (Loc, 5937 Defining_Identifier => Ann, 5938 Object_Definition => 5939 New_Occurrence_Of (RTE (RE_Address), Loc)); 5940 5941 Insert_Before_And_Analyze (Sel_Acc, Adecl); 5942 5943 -- If this is not the first accept statement, then find the Ann 5944 -- variable allocated by the first accept and use it. 5945 5946 else 5947 Ann := 5948 Node (Last_Elmt (Accept_Address 5949 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))))); 5950 end if; 5951 end; 5952 end if; 5953 5954 -- Merge here with Ann either created or referenced, and Adecl 5955 -- pointing to the corresponding declaration. Remaining processing 5956 -- is the same for the two cases. 5957 5958 if Present (Ann) then 5959 Append_Elmt (Ann, Accept_Address (Ent)); 5960 Set_Debug_Info_Needed (Ann); 5961 end if; 5962 5963 -- Create renaming declarations for the entry formals. Each reference 5964 -- to a formal becomes a dereference of a component of the parameter 5965 -- block, whose address is held in Ann. These declarations are 5966 -- eventually inserted into the accept block, and analyzed there so 5967 -- that they have the proper scope for gdb and do not conflict with 5968 -- other declarations. 5969 5970 if Present (Parameter_Specifications (N)) 5971 and then Present (Handled_Statement_Sequence (N)) 5972 then 5973 declare 5974 Comp : Entity_Id; 5975 Decl : Node_Id; 5976 Formal : Entity_Id; 5977 New_F : Entity_Id; 5978 Renamed_Formal : Node_Id; 5979 5980 begin 5981 Push_Scope (Ent); 5982 Formal := First_Formal (Ent); 5983 5984 while Present (Formal) loop 5985 Comp := Entry_Component (Formal); 5986 New_F := Make_Defining_Identifier (Loc, Chars (Formal)); 5987 5988 Set_Etype (New_F, Etype (Formal)); 5989 Set_Scope (New_F, Ent); 5990 5991 -- Now we set debug info needed on New_F even though it does 5992 -- not come from source, so that the debugger will get the 5993 -- right information for these generated names. 5994 5995 Set_Debug_Info_Needed (New_F); 5996 5997 if Ekind (Formal) = E_In_Parameter then 5998 Set_Ekind (New_F, E_Constant); 5999 else 6000 Set_Ekind (New_F, E_Variable); 6001 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 6002 end if; 6003 6004 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 6005 6006 Renamed_Formal := 6007 Make_Selected_Component (Loc, 6008 Prefix => 6009 Unchecked_Convert_To ( 6010 Entry_Parameters_Type (Ent), 6011 New_Occurrence_Of (Ann, Loc)), 6012 Selector_Name => 6013 New_Occurrence_Of (Comp, Loc)); 6014 6015 Decl := 6016 Build_Renamed_Formal_Declaration 6017 (New_F, Formal, Comp, Renamed_Formal); 6018 6019 if No (Declarations (N)) then 6020 Set_Declarations (N, New_List); 6021 end if; 6022 6023 Append (Decl, Declarations (N)); 6024 Set_Renamed_Object (Formal, New_F); 6025 Next_Formal (Formal); 6026 end loop; 6027 6028 End_Scope; 6029 end; 6030 end if; 6031 end if; 6032 end Expand_Accept_Declarations; 6033 6034 --------------------------------------------- 6035 -- Expand_Access_Protected_Subprogram_Type -- 6036 --------------------------------------------- 6037 6038 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is 6039 Loc : constant Source_Ptr := Sloc (N); 6040 T : constant Entity_Id := Defining_Identifier (N); 6041 D_T : constant Entity_Id := Designated_Type (T); 6042 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D'); 6043 E_T : constant Entity_Id := Make_Temporary (Loc, 'E'); 6044 P_List : constant List_Id := 6045 Build_Protected_Spec (N, RTE (RE_Address), D_T, False); 6046 6047 Comps : List_Id; 6048 Decl1 : Node_Id; 6049 Decl2 : Node_Id; 6050 Def1 : Node_Id; 6051 6052 begin 6053 -- Create access to subprogram with full signature 6054 6055 if Etype (D_T) /= Standard_Void_Type then 6056 Def1 := 6057 Make_Access_Function_Definition (Loc, 6058 Parameter_Specifications => P_List, 6059 Result_Definition => 6060 Copy_Result_Type (Result_Definition (Type_Definition (N)))); 6061 6062 else 6063 Def1 := 6064 Make_Access_Procedure_Definition (Loc, 6065 Parameter_Specifications => P_List); 6066 end if; 6067 6068 Decl1 := 6069 Make_Full_Type_Declaration (Loc, 6070 Defining_Identifier => D_T2, 6071 Type_Definition => Def1); 6072 6073 -- Declare the new types before the original one since the latter will 6074 -- refer to them through the Equivalent_Type slot. 6075 6076 Insert_Before_And_Analyze (N, Decl1); 6077 6078 -- Associate the access to subprogram with its original access to 6079 -- protected subprogram type. Needed by the backend to know that this 6080 -- type corresponds with an access to protected subprogram type. 6081 6082 Set_Original_Access_Type (D_T2, T); 6083 6084 -- Create Equivalent_Type, a record with two components for an access to 6085 -- object and an access to subprogram. 6086 6087 Comps := New_List ( 6088 Make_Component_Declaration (Loc, 6089 Defining_Identifier => Make_Temporary (Loc, 'P'), 6090 Component_Definition => 6091 Make_Component_Definition (Loc, 6092 Aliased_Present => False, 6093 Subtype_Indication => 6094 New_Occurrence_Of (RTE (RE_Address), Loc))), 6095 6096 Make_Component_Declaration (Loc, 6097 Defining_Identifier => Make_Temporary (Loc, 'S'), 6098 Component_Definition => 6099 Make_Component_Definition (Loc, 6100 Aliased_Present => False, 6101 Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); 6102 6103 Decl2 := 6104 Make_Full_Type_Declaration (Loc, 6105 Defining_Identifier => E_T, 6106 Type_Definition => 6107 Make_Record_Definition (Loc, 6108 Component_List => 6109 Make_Component_List (Loc, Component_Items => Comps))); 6110 6111 Insert_Before_And_Analyze (N, Decl2); 6112 Set_Equivalent_Type (T, E_T); 6113 end Expand_Access_Protected_Subprogram_Type; 6114 6115 -------------------------- 6116 -- Expand_Entry_Barrier -- 6117 -------------------------- 6118 6119 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is 6120 Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N)); 6121 Prot : constant Entity_Id := Scope (Ent); 6122 Spec_Decl : constant Node_Id := Parent (Prot); 6123 6124 Func_Id : Entity_Id := Empty; 6125 -- The entity of the barrier function 6126 6127 function Is_Global_Entity (N : Node_Id) return Traverse_Result; 6128 -- Check whether entity in Barrier is external to protected type. 6129 -- If so, barrier may not be properly synchronized. 6130 6131 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result; 6132 -- Check whether N follows the Pure_Barriers restriction. Return OK if 6133 -- so. 6134 6135 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean; 6136 -- Check whether entity name N denotes a component of the protected 6137 -- object. This is used to check the Simple_Barrier restriction. 6138 6139 ---------------------- 6140 -- Is_Global_Entity -- 6141 ---------------------- 6142 6143 function Is_Global_Entity (N : Node_Id) return Traverse_Result is 6144 E : Entity_Id; 6145 S : Entity_Id; 6146 6147 begin 6148 if Is_Entity_Name (N) and then Present (Entity (N)) then 6149 E := Entity (N); 6150 S := Scope (E); 6151 6152 if Ekind (E) = E_Variable then 6153 6154 -- If the variable is local to the barrier function generated 6155 -- during expansion, it is ok. If expansion is not performed, 6156 -- then Func is Empty so this test cannot succeed. 6157 6158 if Scope (E) = Func_Id then 6159 null; 6160 6161 -- A protected call from a barrier to another object is ok 6162 6163 elsif Ekind (Etype (E)) = E_Protected_Type then 6164 null; 6165 6166 -- If the variable is within the package body we consider 6167 -- this safe. This is a common (if dubious) idiom. 6168 6169 elsif S = Scope (Prot) 6170 and then Ekind_In (S, E_Package, E_Generic_Package) 6171 and then Nkind (Parent (E)) = N_Object_Declaration 6172 and then Nkind (Parent (Parent (E))) = N_Package_Body 6173 then 6174 null; 6175 6176 else 6177 Error_Msg_N ("potentially unsynchronized barrier??", N); 6178 Error_Msg_N ("\& should be private component of type??", N); 6179 end if; 6180 end if; 6181 end if; 6182 6183 return OK; 6184 end Is_Global_Entity; 6185 6186 procedure Check_Unprotected_Barrier is 6187 new Traverse_Proc (Is_Global_Entity); 6188 6189 ---------------------------- 6190 -- Is_Simple_Barrier_Name -- 6191 ---------------------------- 6192 6193 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is 6194 Renamed : Node_Id; 6195 6196 begin 6197 -- Check if the name is a component of the protected object. If 6198 -- the expander is active, the component has been transformed into a 6199 -- renaming of _object.all.component. Original_Node is needed in case 6200 -- validity checking is enabled, in which case the simple object 6201 -- reference will have been rewritten. 6202 6203 if Expander_Active then 6204 6205 -- The expanded name may have been constant folded in which case 6206 -- the original node is not necessarily an entity name (e.g. an 6207 -- indexed component). 6208 6209 if not Is_Entity_Name (Original_Node (N)) then 6210 return False; 6211 end if; 6212 6213 Renamed := Renamed_Object (Entity (Original_Node (N))); 6214 6215 return 6216 Present (Renamed) 6217 and then Nkind (Renamed) = N_Selected_Component 6218 and then Chars (Prefix (Prefix (Renamed))) = Name_uObject; 6219 else 6220 return Is_Protected_Component (Entity (N)); 6221 end if; 6222 end Is_Simple_Barrier_Name; 6223 6224 --------------------- 6225 -- Is_Pure_Barrier -- 6226 --------------------- 6227 6228 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is 6229 begin 6230 case Nkind (N) is 6231 when N_Expanded_Name 6232 | N_Identifier 6233 => 6234 if No (Entity (N)) then 6235 return Abandon; 6236 6237 elsif Is_Universal_Numeric_Type (Entity (N)) then 6238 return OK; 6239 end if; 6240 6241 case Ekind (Entity (N)) is 6242 when E_Constant 6243 | E_Discriminant 6244 | E_Enumeration_Literal 6245 | E_Named_Integer 6246 | E_Named_Real 6247 => 6248 return OK; 6249 6250 when E_Component => 6251 return OK; 6252 6253 when E_Variable => 6254 if Is_Simple_Barrier_Name (N) then 6255 return OK; 6256 end if; 6257 6258 when E_Function => 6259 6260 -- The count attribute has been transformed into run-time 6261 -- calls. 6262 6263 if Is_RTE (Entity (N), RE_Protected_Count) 6264 or else Is_RTE (Entity (N), RE_Protected_Count_Entry) 6265 then 6266 return OK; 6267 end if; 6268 6269 when others => 6270 null; 6271 end case; 6272 6273 when N_Function_Call => 6274 6275 -- Function call checks are carried out as part of the analysis 6276 -- of the function call name. 6277 6278 return OK; 6279 6280 when N_Character_Literal 6281 | N_Integer_Literal 6282 | N_Real_Literal 6283 => 6284 return OK; 6285 6286 when N_Op_Boolean 6287 | N_Op_Not 6288 => 6289 if Ekind (Entity (N)) = E_Operator then 6290 return OK; 6291 end if; 6292 6293 when N_Short_Circuit => 6294 return OK; 6295 6296 when N_Indexed_Component 6297 | N_Selected_Component 6298 => 6299 if not Is_Access_Type (Etype (Prefix (N))) then 6300 return OK; 6301 end if; 6302 6303 when N_Type_Conversion => 6304 6305 -- Conversions to Universal_Integer will not raise constraint 6306 -- errors. 6307 6308 if Cannot_Raise_Constraint_Error (N) 6309 or else Etype (N) = Universal_Integer 6310 then 6311 return OK; 6312 end if; 6313 6314 when N_Unchecked_Type_Conversion => 6315 return OK; 6316 6317 when others => 6318 null; 6319 end case; 6320 6321 return Abandon; 6322 end Is_Pure_Barrier; 6323 6324 function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier); 6325 6326 -- Local variables 6327 6328 Cond_Id : Entity_Id; 6329 Entry_Body : Node_Id; 6330 Func_Body : Node_Id := Empty; 6331 6332 -- Start of processing for Expand_Entry_Barrier 6333 6334 begin 6335 if No_Run_Time_Mode then 6336 Error_Msg_CRT ("entry barrier", N); 6337 return; 6338 end if; 6339 6340 -- The body of the entry barrier must be analyzed in the context of the 6341 -- protected object, but its scope is external to it, just as any other 6342 -- unprotected version of a protected operation. The specification has 6343 -- been produced when the protected type declaration was elaborated. We 6344 -- build the body, insert it in the enclosing scope, but analyze it in 6345 -- the current context. A more uniform approach would be to treat the 6346 -- barrier just as a protected function, and discard the protected 6347 -- version of it because it is never called. 6348 6349 if Expander_Active then 6350 Func_Body := Build_Barrier_Function (N, Ent, Prot); 6351 Func_Id := Barrier_Function (Ent); 6352 Set_Corresponding_Spec (Func_Body, Func_Id); 6353 6354 Entry_Body := Parent (Corresponding_Body (Spec_Decl)); 6355 6356 if Nkind (Parent (Entry_Body)) = N_Subunit then 6357 Entry_Body := Corresponding_Stub (Parent (Entry_Body)); 6358 end if; 6359 6360 Insert_Before_And_Analyze (Entry_Body, Func_Body); 6361 6362 Set_Discriminals (Spec_Decl); 6363 Set_Scope (Func_Id, Scope (Prot)); 6364 6365 else 6366 Analyze_And_Resolve (Cond, Any_Boolean); 6367 end if; 6368 6369 -- Check Pure_Barriers restriction 6370 6371 if Check_Pure_Barriers (Cond) = Abandon then 6372 Check_Restriction (Pure_Barriers, Cond); 6373 end if; 6374 6375 -- The Ravenscar profile restricts barriers to simple variables declared 6376 -- within the protected object. We also allow Boolean constants, since 6377 -- these appear in several published examples and are also allowed by 6378 -- other compilers. 6379 6380 -- Note that after analysis variables in this context will be replaced 6381 -- by the corresponding prival, that is to say a renaming of a selected 6382 -- component of the form _Object.Var. If expansion is disabled, as 6383 -- within a generic, we check that the entity appears in the current 6384 -- scope. 6385 6386 if Is_Entity_Name (Cond) then 6387 Cond_Id := Entity (Cond); 6388 6389 -- Perform a small optimization of simple barrier functions. If the 6390 -- scope of the condition's entity is not the barrier function, then 6391 -- the condition does not depend on any of the generated renamings. 6392 -- If this is the case, eliminate the renamings as they are useless. 6393 -- This optimization is not performed when the condition was folded 6394 -- and validity checks are in effect because the original condition 6395 -- may have produced at least one check that depends on the generated 6396 -- renamings. 6397 6398 if Expander_Active 6399 and then Scope (Cond_Id) /= Func_Id 6400 and then not Validity_Check_Operands 6401 then 6402 Set_Declarations (Func_Body, Empty_List); 6403 end if; 6404 6405 if Cond_Id = Standard_False or else Cond_Id = Standard_True then 6406 return; 6407 6408 elsif Is_Simple_Barrier_Name (Cond) then 6409 return; 6410 end if; 6411 end if; 6412 6413 -- It is not a boolean variable or literal, so check the restriction. 6414 -- Note that it is safe to be calling Check_Restriction from here, even 6415 -- though this is part of the expander, since Expand_Entry_Barrier is 6416 -- called from Sem_Ch9 even in -gnatc mode. 6417 6418 Check_Restriction (Simple_Barriers, Cond); 6419 6420 -- Emit warning if barrier contains global entities and is thus 6421 -- potentially unsynchronized. 6422 6423 Check_Unprotected_Barrier (Cond); 6424 end Expand_Entry_Barrier; 6425 6426 ------------------------------ 6427 -- Expand_N_Abort_Statement -- 6428 ------------------------------ 6429 6430 -- Expand abort T1, T2, .. Tn; into: 6431 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...)) 6432 6433 procedure Expand_N_Abort_Statement (N : Node_Id) is 6434 Loc : constant Source_Ptr := Sloc (N); 6435 Tlist : constant List_Id := Names (N); 6436 Count : Nat; 6437 Aggr : Node_Id; 6438 Tasknm : Node_Id; 6439 6440 begin 6441 Aggr := Make_Aggregate (Loc, Component_Associations => New_List); 6442 Count := 0; 6443 6444 Tasknm := First (Tlist); 6445 6446 while Present (Tasknm) loop 6447 Count := Count + 1; 6448 6449 -- A task interface class-wide type object is being aborted. Retrieve 6450 -- its _task_id by calling a dispatching routine. 6451 6452 if Ada_Version >= Ada_2005 6453 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type 6454 and then Is_Interface (Etype (Tasknm)) 6455 and then Is_Task_Interface (Etype (Tasknm)) 6456 then 6457 Append_To (Component_Associations (Aggr), 6458 Make_Component_Association (Loc, 6459 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6460 Expression => 6461 6462 -- Task_Id (Tasknm._disp_get_task_id) 6463 6464 Make_Unchecked_Type_Conversion (Loc, 6465 Subtype_Mark => 6466 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 6467 Expression => 6468 Make_Selected_Component (Loc, 6469 Prefix => New_Copy_Tree (Tasknm), 6470 Selector_Name => 6471 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))); 6472 6473 else 6474 Append_To (Component_Associations (Aggr), 6475 Make_Component_Association (Loc, 6476 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6477 Expression => Concurrent_Ref (Tasknm))); 6478 end if; 6479 6480 Next (Tasknm); 6481 end loop; 6482 6483 Rewrite (N, 6484 Make_Procedure_Call_Statement (Loc, 6485 Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc), 6486 Parameter_Associations => New_List ( 6487 Make_Qualified_Expression (Loc, 6488 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_List), Loc), 6489 Expression => Aggr)))); 6490 6491 Analyze (N); 6492 end Expand_N_Abort_Statement; 6493 6494 ------------------------------- 6495 -- Expand_N_Accept_Statement -- 6496 ------------------------------- 6497 6498 -- This procedure handles expansion of accept statements that stand alone, 6499 -- i.e. they are not part of an accept alternative. The expansion of 6500 -- accept statement in accept alternatives is handled by the routines 6501 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The 6502 -- following description applies only to stand alone accept statements. 6503 6504 -- If there is no handled statement sequence, or only null statements, then 6505 -- this is called a trivial accept, and the expansion is: 6506 6507 -- Accept_Trivial (entry-index) 6508 6509 -- If there is a handled statement sequence, then the expansion is: 6510 6511 -- Ann : Address; 6512 -- {Lnn : Label} 6513 6514 -- begin 6515 -- begin 6516 -- Accept_Call (entry-index, Ann); 6517 -- Renaming_Declarations for formals 6518 -- <statement sequence from N_Accept_Statement node> 6519 -- Complete_Rendezvous; 6520 -- <<Lnn>> 6521 -- 6522 -- exception 6523 -- when ... => 6524 -- <exception handler from N_Accept_Statement node> 6525 -- Complete_Rendezvous; 6526 -- when ... => 6527 -- <exception handler from N_Accept_Statement node> 6528 -- Complete_Rendezvous; 6529 -- ... 6530 -- end; 6531 6532 -- exception 6533 -- when all others => 6534 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 6535 -- end; 6536 6537 -- The first three declarations were already inserted ahead of the accept 6538 -- statement by the Expand_Accept_Declarations procedure, which was called 6539 -- directly from the semantics during analysis of the accept statement, 6540 -- before analyzing its contained statements. 6541 6542 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come 6543 -- from possible expansion activity (the original source of course does 6544 -- not have any declarations associated with the accept statement, since 6545 -- an accept statement has no declarative part). In particular, if the 6546 -- expander is active, the first such declaration is the declaration of 6547 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement). 6548 6549 -- The two blocks are merged into a single block if the inner block has 6550 -- no exception handlers, but otherwise two blocks are required, since 6551 -- exceptions might be raised in the exception handlers of the inner 6552 -- block, and Exceptional_Complete_Rendezvous must be called. 6553 6554 procedure Expand_N_Accept_Statement (N : Node_Id) is 6555 Loc : constant Source_Ptr := Sloc (N); 6556 Stats : constant Node_Id := Handled_Statement_Sequence (N); 6557 Ename : constant Node_Id := Entry_Direct_Name (N); 6558 Eindx : constant Node_Id := Entry_Index (N); 6559 Eent : constant Entity_Id := Entity (Ename); 6560 Acstack : constant Elist_Id := Accept_Address (Eent); 6561 Ann : constant Entity_Id := Node (Last_Elmt (Acstack)); 6562 Ttyp : constant Entity_Id := Etype (Scope (Eent)); 6563 Blkent : Entity_Id; 6564 Call : Node_Id; 6565 Block : Node_Id; 6566 6567 begin 6568 -- If the accept statement is not part of a list, then its parent must 6569 -- be an accept alternative, and, as described above, we do not do any 6570 -- expansion for such accept statements at this level. 6571 6572 if not Is_List_Member (N) then 6573 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative); 6574 return; 6575 6576 -- Trivial accept case (no statement sequence, or null statements). 6577 -- If the accept statement has declarations, then just insert them 6578 -- before the procedure call. 6579 6580 elsif Trivial_Accept_OK 6581 and then (No (Stats) or else Null_Statements (Statements (Stats))) 6582 then 6583 -- Remove declarations for renamings, because the parameter block 6584 -- will not be assigned. 6585 6586 declare 6587 D : Node_Id; 6588 Next_D : Node_Id; 6589 6590 begin 6591 D := First (Declarations (N)); 6592 while Present (D) loop 6593 Next_D := Next (D); 6594 if Nkind (D) = N_Object_Renaming_Declaration then 6595 Remove (D); 6596 end if; 6597 6598 D := Next_D; 6599 end loop; 6600 end; 6601 6602 if Present (Declarations (N)) then 6603 Insert_Actions (N, Declarations (N)); 6604 end if; 6605 6606 Rewrite (N, 6607 Make_Procedure_Call_Statement (Loc, 6608 Name => New_Occurrence_Of (RTE (RE_Accept_Trivial), Loc), 6609 Parameter_Associations => New_List ( 6610 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp)))); 6611 6612 Analyze (N); 6613 6614 -- Discard Entry_Address that was created for it, so it will not be 6615 -- emitted if this accept statement is in the statement part of a 6616 -- delay alternative. 6617 6618 if Present (Stats) then 6619 Remove_Last_Elmt (Acstack); 6620 end if; 6621 6622 -- Case of statement sequence present 6623 6624 else 6625 -- Construct the block, using the declarations from the accept 6626 -- statement if any to initialize the declarations of the block. 6627 6628 Blkent := Make_Temporary (Loc, 'A'); 6629 Set_Ekind (Blkent, E_Block); 6630 Set_Etype (Blkent, Standard_Void_Type); 6631 Set_Scope (Blkent, Current_Scope); 6632 6633 Block := 6634 Make_Block_Statement (Loc, 6635 Identifier => New_Occurrence_Of (Blkent, Loc), 6636 Declarations => Declarations (N), 6637 Handled_Statement_Sequence => Build_Accept_Body (N)); 6638 6639 -- Reset the Scope of local entities associated with the accept 6640 -- statement (that currently reference the entry scope) to the 6641 -- block scope, to avoid having references to the locals treated 6642 -- as up-level references. 6643 6644 Reset_Scopes_To (Block, Blkent); 6645 6646 -- For the analysis of the generated declarations, the parent node 6647 -- must be properly set. 6648 6649 Set_Parent (Block, Parent (N)); 6650 6651 -- Prepend call to Accept_Call to main statement sequence If the 6652 -- accept has exception handlers, the statement sequence is wrapped 6653 -- in a block. Insert call and renaming declarations in the 6654 -- declarations of the block, so they are elaborated before the 6655 -- handlers. 6656 6657 Call := 6658 Make_Procedure_Call_Statement (Loc, 6659 Name => New_Occurrence_Of (RTE (RE_Accept_Call), Loc), 6660 Parameter_Associations => New_List ( 6661 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp), 6662 New_Occurrence_Of (Ann, Loc))); 6663 6664 if Parent (Stats) = N then 6665 Prepend (Call, Statements (Stats)); 6666 else 6667 Set_Declarations (Parent (Stats), New_List (Call)); 6668 end if; 6669 6670 Analyze (Call); 6671 6672 Push_Scope (Blkent); 6673 6674 declare 6675 D : Node_Id; 6676 Next_D : Node_Id; 6677 Typ : Entity_Id; 6678 6679 begin 6680 D := First (Declarations (N)); 6681 while Present (D) loop 6682 Next_D := Next (D); 6683 6684 if Nkind (D) = N_Object_Renaming_Declaration then 6685 6686 -- The renaming declarations for the formals were created 6687 -- during analysis of the accept statement, and attached to 6688 -- the list of declarations. Place them now in the context 6689 -- of the accept block or subprogram. 6690 6691 Remove (D); 6692 Typ := Entity (Subtype_Mark (D)); 6693 Insert_After (Call, D); 6694 Analyze (D); 6695 6696 -- If the formal is class_wide, it does not have an actual 6697 -- subtype. The analysis of the renaming declaration creates 6698 -- one, but we need to retain the class-wide nature of the 6699 -- entity. 6700 6701 if Is_Class_Wide_Type (Typ) then 6702 Set_Etype (Defining_Identifier (D), Typ); 6703 end if; 6704 6705 end if; 6706 6707 D := Next_D; 6708 end loop; 6709 end; 6710 6711 End_Scope; 6712 6713 -- Replace the accept statement by the new block 6714 6715 Rewrite (N, Block); 6716 Analyze (N); 6717 6718 -- Last step is to unstack the Accept_Address value 6719 6720 Remove_Last_Elmt (Acstack); 6721 end if; 6722 end Expand_N_Accept_Statement; 6723 6724 ---------------------------------- 6725 -- Expand_N_Asynchronous_Select -- 6726 ---------------------------------- 6727 6728 -- This procedure assumes that the trigger statement is an entry call or 6729 -- a dispatching procedure call. A delay alternative should already have 6730 -- been expanded into an entry call to the appropriate delay object Wait 6731 -- entry. 6732 6733 -- If the trigger is a task entry call, the select is implemented with 6734 -- a Task_Entry_Call: 6735 6736 -- declare 6737 -- B : Boolean; 6738 -- C : Boolean; 6739 -- P : parms := (parm, parm, parm); 6740 6741 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6742 6743 -- procedure _clean is 6744 -- begin 6745 -- ... 6746 -- Cancel_Task_Entry_Call (C); 6747 -- ... 6748 -- end _clean; 6749 6750 -- begin 6751 -- Abort_Defer; 6752 -- Task_Entry_Call 6753 -- (<acceptor-task>, -- Acceptor 6754 -- <entry-index>, -- E 6755 -- P'Address, -- Uninterpreted_Data 6756 -- Asynchronous_Call, -- Mode 6757 -- B); -- Rendezvous_Successful 6758 6759 -- begin 6760 -- begin 6761 -- Abort_Undefer; 6762 -- <abortable-part> 6763 -- at end 6764 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6765 -- end; 6766 -- exception 6767 -- when Abort_Signal => Abort_Undefer; 6768 -- end; 6769 6770 -- parm := P.param; 6771 -- parm := P.param; 6772 -- ... 6773 -- if not C then 6774 -- <triggered-statements> 6775 -- end if; 6776 -- end; 6777 6778 -- Note that Build_Simple_Entry_Call is used to expand the entry of the 6779 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure) 6780 -- as follows: 6781 6782 -- declare 6783 -- P : parms := (parm, parm, parm); 6784 -- begin 6785 -- Call_Simple (acceptor-task, entry-index, P'Address); 6786 -- parm := P.param; 6787 -- parm := P.param; 6788 -- ... 6789 -- end; 6790 6791 -- so the task at hand is to convert the latter expansion into the former 6792 6793 -- If the trigger is a protected entry call, the select is implemented 6794 -- with Protected_Entry_Call: 6795 6796 -- declare 6797 -- P : E1_Params := (param, param, param); 6798 -- Bnn : Communications_Block; 6799 6800 -- begin 6801 -- declare 6802 6803 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6804 6805 -- procedure _clean is 6806 -- begin 6807 -- ... 6808 -- if Enqueued (Bnn) then 6809 -- Cancel_Protected_Entry_Call (Bnn); 6810 -- end if; 6811 -- ... 6812 -- end _clean; 6813 6814 -- begin 6815 -- begin 6816 -- Protected_Entry_Call 6817 -- (po._object'Access, -- Object 6818 -- <entry index>, -- E 6819 -- P'Address, -- Uninterpreted_Data 6820 -- Asynchronous_Call, -- Mode 6821 -- Bnn); -- Block 6822 6823 -- if Enqueued (Bnn) then 6824 -- <abortable-part> 6825 -- end if; 6826 -- at end 6827 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6828 -- end; 6829 -- exception 6830 -- when Abort_Signal => Abort_Undefer; 6831 -- end; 6832 6833 -- if not Cancelled (Bnn) then 6834 -- <triggered-statements> 6835 -- end if; 6836 -- end; 6837 6838 -- Build_Simple_Entry_Call is used to expand the all to a simple protected 6839 -- entry call: 6840 6841 -- declare 6842 -- P : E1_Params := (param, param, param); 6843 -- Bnn : Communications_Block; 6844 6845 -- begin 6846 -- Protected_Entry_Call 6847 -- (po._object'Access, -- Object 6848 -- <entry index>, -- E 6849 -- P'Address, -- Uninterpreted_Data 6850 -- Simple_Call, -- Mode 6851 -- Bnn); -- Block 6852 -- parm := P.param; 6853 -- parm := P.param; 6854 -- ... 6855 -- end; 6856 6857 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is 6858 -- expanded into: 6859 6860 -- declare 6861 -- B : Boolean := False; 6862 -- Bnn : Communication_Block; 6863 -- C : Ada.Tags.Prim_Op_Kind; 6864 -- D : System.Storage_Elements.Dummy_Communication_Block; 6865 -- K : Ada.Tags.Tagged_Kind := 6866 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 6867 -- P : Parameters := (Param1 .. ParamN); 6868 -- S : Integer; 6869 -- U : Boolean; 6870 6871 -- begin 6872 -- if K = Ada.Tags.TK_Limited_Tagged 6873 -- or else K = Ada.Tags.TK_Tagged 6874 -- then 6875 -- <dispatching-call>; 6876 -- <triggering-statements>; 6877 6878 -- else 6879 -- S := 6880 -- Ada.Tags.Get_Offset_Index 6881 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 6882 6883 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 6884 6885 -- if C = POK_Protected_Entry then 6886 -- declare 6887 -- procedure _clean is 6888 -- begin 6889 -- if Enqueued (Bnn) then 6890 -- Cancel_Protected_Entry_Call (Bnn); 6891 -- end if; 6892 -- end _clean; 6893 6894 -- begin 6895 -- begin 6896 -- _Disp_Asynchronous_Select 6897 -- (<object>, S, P'Address, D, B); 6898 -- Bnn := Communication_Block (D); 6899 6900 -- Param1 := P.Param1; 6901 -- ... 6902 -- ParamN := P.ParamN; 6903 6904 -- if Enqueued (Bnn) then 6905 -- <abortable-statements> 6906 -- end if; 6907 -- at end 6908 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6909 -- end; 6910 -- exception 6911 -- when Abort_Signal => Abort_Undefer; 6912 -- end; 6913 6914 -- if not Cancelled (Bnn) then 6915 -- <triggering-statements> 6916 -- end if; 6917 6918 -- elsif C = POK_Task_Entry then 6919 -- declare 6920 -- procedure _clean is 6921 -- begin 6922 -- Cancel_Task_Entry_Call (U); 6923 -- end _clean; 6924 6925 -- begin 6926 -- Abort_Defer; 6927 6928 -- _Disp_Asynchronous_Select 6929 -- (<object>, S, P'Address, D, B); 6930 -- Bnn := Communication_Bloc (D); 6931 6932 -- Param1 := P.Param1; 6933 -- ... 6934 -- ParamN := P.ParamN; 6935 6936 -- begin 6937 -- begin 6938 -- Abort_Undefer; 6939 -- <abortable-statements> 6940 -- at end 6941 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6942 -- end; 6943 -- exception 6944 -- when Abort_Signal => Abort_Undefer; 6945 -- end; 6946 6947 -- if not U then 6948 -- <triggering-statements> 6949 -- end if; 6950 -- end; 6951 6952 -- else 6953 -- <dispatching-call>; 6954 -- <triggering-statements> 6955 -- end if; 6956 -- end if; 6957 -- end; 6958 6959 -- The job is to convert this to the asynchronous form 6960 6961 -- If the trigger is a delay statement, it will have been expanded into 6962 -- a call to one of the GNARL delay procedures. This routine will convert 6963 -- this into a protected entry call on a delay object and then continue 6964 -- processing as for a protected entry call trigger. This requires 6965 -- declaring a Delay_Block object and adding a pointer to this object to 6966 -- the parameter list of the delay procedure to form the parameter list of 6967 -- the entry call. This object is used by the runtime to queue the delay 6968 -- request. 6969 6970 -- For a description of the use of P and the assignments after the call, 6971 -- see Expand_N_Entry_Call_Statement. 6972 6973 procedure Expand_N_Asynchronous_Select (N : Node_Id) is 6974 Loc : constant Source_Ptr := Sloc (N); 6975 Abrt : constant Node_Id := Abortable_Part (N); 6976 Trig : constant Node_Id := Triggering_Alternative (N); 6977 6978 Abort_Block_Ent : Entity_Id; 6979 Abortable_Block : Node_Id; 6980 Actuals : List_Id; 6981 Astats : List_Id; 6982 Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A'); 6983 Blk_Typ : Entity_Id; 6984 Call : Node_Id; 6985 Call_Ent : Entity_Id; 6986 Cancel_Param : Entity_Id; 6987 Cleanup_Block : Node_Id; 6988 Cleanup_Block_Ent : Entity_Id; 6989 Cleanup_Stmts : List_Id; 6990 Conc_Typ_Stmts : List_Id; 6991 Concval : Node_Id; 6992 Dblock_Ent : Entity_Id; 6993 Decl : Node_Id; 6994 Decls : List_Id; 6995 Ecall : Node_Id; 6996 Ename : Node_Id; 6997 Enqueue_Call : Node_Id; 6998 Formals : List_Id; 6999 Hdle : List_Id; 7000 Handler_Stmt : Node_Id; 7001 Index : Node_Id; 7002 Lim_Typ_Stmts : List_Id; 7003 N_Orig : Node_Id; 7004 Obj : Entity_Id; 7005 Param : Node_Id; 7006 Params : List_Id; 7007 Pdef : Entity_Id; 7008 ProtE_Stmts : List_Id; 7009 ProtP_Stmts : List_Id; 7010 Stmt : Node_Id; 7011 Stmts : List_Id; 7012 TaskE_Stmts : List_Id; 7013 Tstats : List_Id; 7014 7015 B : Entity_Id; -- Call status flag 7016 Bnn : Entity_Id; -- Communication block 7017 C : Entity_Id; -- Call kind 7018 K : Entity_Id; -- Tagged kind 7019 P : Entity_Id; -- Parameter block 7020 S : Entity_Id; -- Primitive operation slot 7021 T : Entity_Id; -- Additional status flag 7022 7023 procedure Rewrite_Abortable_Part; 7024 -- If the trigger is a dispatching call, the expansion inserts multiple 7025 -- copies of the abortable part. This is both inefficient, and may lead 7026 -- to duplicate definitions that the back-end will reject, when the 7027 -- abortable part includes loops. This procedure rewrites the abortable 7028 -- part into a call to a generated procedure. 7029 7030 ---------------------------- 7031 -- Rewrite_Abortable_Part -- 7032 ---------------------------- 7033 7034 procedure Rewrite_Abortable_Part is 7035 Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 7036 Decl : Node_Id; 7037 7038 begin 7039 Decl := 7040 Make_Subprogram_Body (Loc, 7041 Specification => 7042 Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc), 7043 Declarations => New_List, 7044 Handled_Statement_Sequence => 7045 Make_Handled_Sequence_Of_Statements (Loc, Astats)); 7046 Insert_Before (N, Decl); 7047 Analyze (Decl); 7048 7049 -- Rewrite abortable part into a call to this procedure 7050 7051 Astats := 7052 New_List ( 7053 Make_Procedure_Call_Statement (Loc, 7054 Name => New_Occurrence_Of (Proc, Loc))); 7055 end Rewrite_Abortable_Part; 7056 7057 -- Start of processing for Expand_N_Asynchronous_Select 7058 7059 begin 7060 -- Asynchronous select is not supported on restricted runtimes. Don't 7061 -- try to expand. 7062 7063 if Restricted_Profile then 7064 return; 7065 end if; 7066 7067 Process_Statements_For_Controlled_Objects (Trig); 7068 Process_Statements_For_Controlled_Objects (Abrt); 7069 7070 Ecall := Triggering_Statement (Trig); 7071 7072 Ensure_Statement_Present (Sloc (Ecall), Trig); 7073 7074 -- Retrieve Astats and Tstats now because the finalization machinery may 7075 -- wrap them in blocks. 7076 7077 Astats := Statements (Abrt); 7078 Tstats := Statements (Trig); 7079 7080 -- The arguments in the call may require dynamic allocation, and the 7081 -- call statement may have been transformed into a block. The block 7082 -- may contain additional declarations for internal entities, and the 7083 -- original call is found by sequential search. 7084 7085 if Nkind (Ecall) = N_Block_Statement then 7086 Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); 7087 while not Nkind_In (Ecall, N_Procedure_Call_Statement, 7088 N_Entry_Call_Statement) 7089 loop 7090 Next (Ecall); 7091 end loop; 7092 end if; 7093 7094 -- This is either a dispatching call or a delay statement used as a 7095 -- trigger which was expanded into a procedure call. 7096 7097 if Nkind (Ecall) = N_Procedure_Call_Statement then 7098 if Ada_Version >= Ada_2005 7099 and then 7100 (No (Original_Node (Ecall)) 7101 or else not Nkind_In (Original_Node (Ecall), 7102 N_Delay_Relative_Statement, 7103 N_Delay_Until_Statement)) 7104 then 7105 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals); 7106 7107 Rewrite_Abortable_Part; 7108 Decls := New_List; 7109 Stmts := New_List; 7110 7111 -- Call status flag processing, generate: 7112 -- B : Boolean := False; 7113 7114 B := Build_B (Loc, Decls); 7115 7116 -- Communication block processing, generate: 7117 -- Bnn : Communication_Block; 7118 7119 Bnn := Make_Temporary (Loc, 'B'); 7120 Append_To (Decls, 7121 Make_Object_Declaration (Loc, 7122 Defining_Identifier => Bnn, 7123 Object_Definition => 7124 New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); 7125 7126 -- Call kind processing, generate: 7127 -- C : Ada.Tags.Prim_Op_Kind; 7128 7129 C := Build_C (Loc, Decls); 7130 7131 -- Tagged kind processing, generate: 7132 -- K : Ada.Tags.Tagged_Kind := 7133 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7134 7135 -- Dummy communication block, generate: 7136 -- D : Dummy_Communication_Block; 7137 7138 Append_To (Decls, 7139 Make_Object_Declaration (Loc, 7140 Defining_Identifier => 7141 Make_Defining_Identifier (Loc, Name_uD), 7142 Object_Definition => 7143 New_Occurrence_Of 7144 (RTE (RE_Dummy_Communication_Block), Loc))); 7145 7146 K := Build_K (Loc, Decls, Obj); 7147 7148 -- Parameter block processing 7149 7150 Blk_Typ := Build_Parameter_Block 7151 (Loc, Actuals, Formals, Decls); 7152 P := Parameter_Block_Pack 7153 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 7154 7155 -- Dispatch table slot processing, generate: 7156 -- S : Integer; 7157 7158 S := Build_S (Loc, Decls); 7159 7160 -- Additional status flag processing, generate: 7161 -- Tnn : Boolean; 7162 7163 T := Make_Temporary (Loc, 'T'); 7164 Append_To (Decls, 7165 Make_Object_Declaration (Loc, 7166 Defining_Identifier => T, 7167 Object_Definition => 7168 New_Occurrence_Of (Standard_Boolean, Loc))); 7169 7170 ------------------------------ 7171 -- Protected entry handling -- 7172 ------------------------------ 7173 7174 -- Generate: 7175 -- Param1 := P.Param1; 7176 -- ... 7177 -- ParamN := P.ParamN; 7178 7179 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7180 7181 -- Generate: 7182 -- Bnn := Communication_Block (D); 7183 7184 Prepend_To (Cleanup_Stmts, 7185 Make_Assignment_Statement (Loc, 7186 Name => New_Occurrence_Of (Bnn, Loc), 7187 Expression => 7188 Make_Unchecked_Type_Conversion (Loc, 7189 Subtype_Mark => 7190 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7191 Expression => Make_Identifier (Loc, Name_uD)))); 7192 7193 -- Generate: 7194 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7195 7196 Prepend_To (Cleanup_Stmts, 7197 Make_Procedure_Call_Statement (Loc, 7198 Name => 7199 New_Occurrence_Of 7200 (Find_Prim_Op 7201 (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select), 7202 Loc), 7203 Parameter_Associations => 7204 New_List ( 7205 New_Copy_Tree (Obj), -- <object> 7206 New_Occurrence_Of (S, Loc), -- S 7207 Make_Attribute_Reference (Loc, -- P'Address 7208 Prefix => New_Occurrence_Of (P, Loc), 7209 Attribute_Name => Name_Address), 7210 Make_Identifier (Loc, Name_uD), -- D 7211 New_Occurrence_Of (B, Loc)))); -- B 7212 7213 -- Generate: 7214 -- if Enqueued (Bnn) then 7215 -- <abortable-statements> 7216 -- end if; 7217 7218 Append_To (Cleanup_Stmts, 7219 Make_Implicit_If_Statement (N, 7220 Condition => 7221 Make_Function_Call (Loc, 7222 Name => 7223 New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7224 Parameter_Associations => 7225 New_List (New_Occurrence_Of (Bnn, Loc))), 7226 7227 Then_Statements => 7228 New_Copy_List_Tree (Astats))); 7229 7230 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7231 -- will then generate a _clean for the communication block Bnn. 7232 7233 -- Generate: 7234 -- declare 7235 -- procedure _clean is 7236 -- begin 7237 -- if Enqueued (Bnn) then 7238 -- Cancel_Protected_Entry_Call (Bnn); 7239 -- end if; 7240 -- end _clean; 7241 -- begin 7242 -- Cleanup_Stmts 7243 -- at end 7244 -- _clean; 7245 -- end; 7246 7247 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7248 Cleanup_Block := 7249 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn); 7250 7251 -- Wrap the cleanup block in an exception handling block 7252 7253 -- Generate: 7254 -- begin 7255 -- Cleanup_Block 7256 -- exception 7257 -- when Abort_Signal => Abort_Undefer; 7258 -- end; 7259 7260 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7261 ProtE_Stmts := 7262 New_List ( 7263 Make_Implicit_Label_Declaration (Loc, 7264 Defining_Identifier => Abort_Block_Ent), 7265 7266 Build_Abort_Block 7267 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7268 7269 -- Generate: 7270 -- if not Cancelled (Bnn) then 7271 -- <triggering-statements> 7272 -- end if; 7273 7274 Append_To (ProtE_Stmts, 7275 Make_Implicit_If_Statement (N, 7276 Condition => 7277 Make_Op_Not (Loc, 7278 Right_Opnd => 7279 Make_Function_Call (Loc, 7280 Name => 7281 New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7282 Parameter_Associations => 7283 New_List (New_Occurrence_Of (Bnn, Loc)))), 7284 7285 Then_Statements => 7286 New_Copy_List_Tree (Tstats))); 7287 7288 ------------------------- 7289 -- Task entry handling -- 7290 ------------------------- 7291 7292 -- Generate: 7293 -- Param1 := P.Param1; 7294 -- ... 7295 -- ParamN := P.ParamN; 7296 7297 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7298 7299 -- Generate: 7300 -- Bnn := Communication_Block (D); 7301 7302 Append_To (TaskE_Stmts, 7303 Make_Assignment_Statement (Loc, 7304 Name => 7305 New_Occurrence_Of (Bnn, Loc), 7306 Expression => 7307 Make_Unchecked_Type_Conversion (Loc, 7308 Subtype_Mark => 7309 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7310 Expression => Make_Identifier (Loc, Name_uD)))); 7311 7312 -- Generate: 7313 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7314 7315 Prepend_To (TaskE_Stmts, 7316 Make_Procedure_Call_Statement (Loc, 7317 Name => 7318 New_Occurrence_Of ( 7319 Find_Prim_Op (Etype (Etype (Obj)), 7320 Name_uDisp_Asynchronous_Select), 7321 Loc), 7322 7323 Parameter_Associations => New_List ( 7324 New_Copy_Tree (Obj), -- <object> 7325 New_Occurrence_Of (S, Loc), -- S 7326 Make_Attribute_Reference (Loc, -- P'Address 7327 Prefix => New_Occurrence_Of (P, Loc), 7328 Attribute_Name => Name_Address), 7329 Make_Identifier (Loc, Name_uD), -- D 7330 New_Occurrence_Of (B, Loc)))); -- B 7331 7332 -- Generate: 7333 -- Abort_Defer; 7334 7335 Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 7336 7337 -- Generate: 7338 -- Abort_Undefer; 7339 -- <abortable-statements> 7340 7341 Cleanup_Stmts := New_Copy_List_Tree (Astats); 7342 7343 Prepend_To 7344 (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7345 7346 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7347 -- will generate a _clean for the additional status flag. 7348 7349 -- Generate: 7350 -- declare 7351 -- procedure _clean is 7352 -- begin 7353 -- Cancel_Task_Entry_Call (U); 7354 -- end _clean; 7355 -- begin 7356 -- Cleanup_Stmts 7357 -- at end 7358 -- _clean; 7359 -- end; 7360 7361 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7362 Cleanup_Block := 7363 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T); 7364 7365 -- Wrap the cleanup block in an exception handling block 7366 7367 -- Generate: 7368 -- begin 7369 -- Cleanup_Block 7370 -- exception 7371 -- when Abort_Signal => Abort_Undefer; 7372 -- end; 7373 7374 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7375 7376 Append_To (TaskE_Stmts, 7377 Make_Implicit_Label_Declaration (Loc, 7378 Defining_Identifier => Abort_Block_Ent)); 7379 7380 Append_To (TaskE_Stmts, 7381 Build_Abort_Block 7382 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7383 7384 -- Generate: 7385 -- if not T then 7386 -- <triggering-statements> 7387 -- end if; 7388 7389 Append_To (TaskE_Stmts, 7390 Make_Implicit_If_Statement (N, 7391 Condition => 7392 Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)), 7393 7394 Then_Statements => 7395 New_Copy_List_Tree (Tstats))); 7396 7397 ---------------------------------- 7398 -- Protected procedure handling -- 7399 ---------------------------------- 7400 7401 -- Generate: 7402 -- <dispatching-call>; 7403 -- <triggering-statements> 7404 7405 ProtP_Stmts := New_Copy_List_Tree (Tstats); 7406 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall)); 7407 7408 -- Generate: 7409 -- S := Ada.Tags.Get_Offset_Index 7410 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 7411 7412 Conc_Typ_Stmts := 7413 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 7414 7415 -- Generate: 7416 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 7417 7418 Append_To (Conc_Typ_Stmts, 7419 Make_Procedure_Call_Statement (Loc, 7420 Name => 7421 New_Occurrence_Of 7422 (Find_Prim_Op (Etype (Etype (Obj)), 7423 Name_uDisp_Get_Prim_Op_Kind), 7424 Loc), 7425 Parameter_Associations => 7426 New_List ( 7427 New_Copy_Tree (Obj), 7428 New_Occurrence_Of (S, Loc), 7429 New_Occurrence_Of (C, Loc)))); 7430 7431 -- Generate: 7432 -- if C = POK_Procedure_Entry then 7433 -- ProtE_Stmts 7434 -- elsif C = POK_Task_Entry then 7435 -- TaskE_Stmts 7436 -- else 7437 -- ProtP_Stmts 7438 -- end if; 7439 7440 Append_To (Conc_Typ_Stmts, 7441 Make_Implicit_If_Statement (N, 7442 Condition => 7443 Make_Op_Eq (Loc, 7444 Left_Opnd => 7445 New_Occurrence_Of (C, Loc), 7446 Right_Opnd => 7447 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 7448 7449 Then_Statements => 7450 ProtE_Stmts, 7451 7452 Elsif_Parts => 7453 New_List ( 7454 Make_Elsif_Part (Loc, 7455 Condition => 7456 Make_Op_Eq (Loc, 7457 Left_Opnd => 7458 New_Occurrence_Of (C, Loc), 7459 Right_Opnd => 7460 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)), 7461 7462 Then_Statements => 7463 TaskE_Stmts)), 7464 7465 Else_Statements => 7466 ProtP_Stmts)); 7467 7468 -- Generate: 7469 -- <dispatching-call>; 7470 -- <triggering-statements> 7471 7472 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats); 7473 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall)); 7474 7475 -- Generate: 7476 -- if K = Ada.Tags.TK_Limited_Tagged 7477 -- or else K = Ada.Tags.TK_Tagged 7478 -- then 7479 -- Lim_Typ_Stmts 7480 -- else 7481 -- Conc_Typ_Stmts 7482 -- end if; 7483 7484 Append_To (Stmts, 7485 Make_Implicit_If_Statement (N, 7486 Condition => Build_Dispatching_Tag_Check (K, N), 7487 Then_Statements => Lim_Typ_Stmts, 7488 Else_Statements => Conc_Typ_Stmts)); 7489 7490 Rewrite (N, 7491 Make_Block_Statement (Loc, 7492 Declarations => 7493 Decls, 7494 Handled_Statement_Sequence => 7495 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7496 7497 Analyze (N); 7498 return; 7499 7500 -- Delay triggering statement processing 7501 7502 else 7503 -- Add a Delay_Block object to the parameter list of the delay 7504 -- procedure to form the parameter list of the Wait entry call. 7505 7506 Dblock_Ent := Make_Temporary (Loc, 'D'); 7507 7508 Pdef := Entity (Name (Ecall)); 7509 7510 if Is_RTE (Pdef, RO_CA_Delay_For) then 7511 Enqueue_Call := 7512 New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc); 7513 7514 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then 7515 Enqueue_Call := 7516 New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc); 7517 7518 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); 7519 Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc); 7520 end if; 7521 7522 Append_To (Parameter_Associations (Ecall), 7523 Make_Attribute_Reference (Loc, 7524 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7525 Attribute_Name => Name_Unchecked_Access)); 7526 7527 -- Create the inner block to protect the abortable part 7528 7529 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7530 7531 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7532 7533 Abortable_Block := 7534 Make_Block_Statement (Loc, 7535 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7536 Handled_Statement_Sequence => 7537 Make_Handled_Sequence_Of_Statements (Loc, 7538 Statements => Astats), 7539 Has_Created_Identifier => True, 7540 Is_Asynchronous_Call_Block => True); 7541 7542 -- Append call to if Enqueue (When, DB'Unchecked_Access) then 7543 7544 Rewrite (Ecall, 7545 Make_Implicit_If_Statement (N, 7546 Condition => 7547 Make_Function_Call (Loc, 7548 Name => Enqueue_Call, 7549 Parameter_Associations => Parameter_Associations (Ecall)), 7550 Then_Statements => 7551 New_List (Make_Block_Statement (Loc, 7552 Handled_Statement_Sequence => 7553 Make_Handled_Sequence_Of_Statements (Loc, 7554 Statements => New_List ( 7555 Make_Implicit_Label_Declaration (Loc, 7556 Defining_Identifier => Blk_Ent, 7557 Label_Construct => Abortable_Block), 7558 Abortable_Block), 7559 Exception_Handlers => Hdle))))); 7560 7561 Stmts := New_List (Ecall); 7562 7563 -- Construct statement sequence for new block 7564 7565 Append_To (Stmts, 7566 Make_Implicit_If_Statement (N, 7567 Condition => 7568 Make_Function_Call (Loc, 7569 Name => New_Occurrence_Of ( 7570 RTE (RE_Timed_Out), Loc), 7571 Parameter_Associations => New_List ( 7572 Make_Attribute_Reference (Loc, 7573 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7574 Attribute_Name => Name_Unchecked_Access))), 7575 Then_Statements => Tstats)); 7576 7577 -- The result is the new block 7578 7579 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent); 7580 7581 Rewrite (N, 7582 Make_Block_Statement (Loc, 7583 Declarations => New_List ( 7584 Make_Object_Declaration (Loc, 7585 Defining_Identifier => Dblock_Ent, 7586 Aliased_Present => True, 7587 Object_Definition => 7588 New_Occurrence_Of (RTE (RE_Delay_Block), Loc))), 7589 7590 Handled_Statement_Sequence => 7591 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7592 7593 Analyze (N); 7594 return; 7595 end if; 7596 7597 else 7598 N_Orig := N; 7599 end if; 7600 7601 Extract_Entry (Ecall, Concval, Ename, Index); 7602 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index); 7603 7604 Stmts := Statements (Handled_Statement_Sequence (Ecall)); 7605 Decls := Declarations (Ecall); 7606 7607 if Is_Protected_Type (Etype (Concval)) then 7608 7609 -- Get the declarations of the block expanded from the entry call 7610 7611 Decl := First (Decls); 7612 while Present (Decl) 7613 and then (Nkind (Decl) /= N_Object_Declaration 7614 or else not Is_RTE (Etype (Object_Definition (Decl)), 7615 RE_Communication_Block)) 7616 loop 7617 Next (Decl); 7618 end loop; 7619 7620 pragma Assert (Present (Decl)); 7621 Cancel_Param := Defining_Identifier (Decl); 7622 7623 -- Change the mode of the Protected_Entry_Call call 7624 7625 -- Protected_Entry_Call ( 7626 -- Object => po._object'Access, 7627 -- E => <entry index>; 7628 -- Uninterpreted_Data => P'Address; 7629 -- Mode => Asynchronous_Call; 7630 -- Block => Bnn); 7631 7632 -- Skip assignments to temporaries created for in-out parameters 7633 7634 -- This makes unwarranted assumptions about the shape of the expanded 7635 -- tree for the call, and should be cleaned up ??? 7636 7637 Stmt := First (Stmts); 7638 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7639 Next (Stmt); 7640 end loop; 7641 7642 Call := Stmt; 7643 7644 Param := First (Parameter_Associations (Call)); 7645 while Present (Param) 7646 and then not Is_RTE (Etype (Param), RE_Call_Modes) 7647 loop 7648 Next (Param); 7649 end loop; 7650 7651 pragma Assert (Present (Param)); 7652 Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7653 Analyze (Param); 7654 7655 -- Append an if statement to execute the abortable part 7656 7657 -- Generate: 7658 -- if Enqueued (Bnn) then 7659 7660 Append_To (Stmts, 7661 Make_Implicit_If_Statement (N, 7662 Condition => 7663 Make_Function_Call (Loc, 7664 Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7665 Parameter_Associations => New_List ( 7666 New_Occurrence_Of (Cancel_Param, Loc))), 7667 Then_Statements => Astats)); 7668 7669 Abortable_Block := 7670 Make_Block_Statement (Loc, 7671 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7672 Handled_Statement_Sequence => 7673 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts), 7674 Has_Created_Identifier => True, 7675 Is_Asynchronous_Call_Block => True); 7676 7677 -- Aborts are not deferred at beginning of exception handlers in 7678 -- ZCX mode. 7679 7680 if ZCX_Exceptions then 7681 Handler_Stmt := Make_Null_Statement (Loc); 7682 7683 else 7684 Handler_Stmt := Build_Runtime_Call (Loc, RE_Abort_Undefer); 7685 end if; 7686 7687 Stmts := New_List ( 7688 Make_Block_Statement (Loc, 7689 Handled_Statement_Sequence => 7690 Make_Handled_Sequence_Of_Statements (Loc, 7691 Statements => New_List ( 7692 Make_Implicit_Label_Declaration (Loc, 7693 Defining_Identifier => Blk_Ent, 7694 Label_Construct => Abortable_Block), 7695 Abortable_Block), 7696 7697 -- exception 7698 7699 Exception_Handlers => New_List ( 7700 Make_Implicit_Exception_Handler (Loc, 7701 7702 -- when Abort_Signal => 7703 -- Abort_Undefer.all; 7704 7705 Exception_Choices => 7706 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)), 7707 Statements => New_List (Handler_Stmt))))), 7708 7709 -- if not Cancelled (Bnn) then 7710 -- triggered statements 7711 -- end if; 7712 7713 Make_Implicit_If_Statement (N, 7714 Condition => Make_Op_Not (Loc, 7715 Right_Opnd => 7716 Make_Function_Call (Loc, 7717 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7718 Parameter_Associations => New_List ( 7719 New_Occurrence_Of (Cancel_Param, Loc)))), 7720 Then_Statements => Tstats)); 7721 7722 -- Asynchronous task entry call 7723 7724 else 7725 if No (Decls) then 7726 Decls := New_List; 7727 end if; 7728 7729 B := Make_Defining_Identifier (Loc, Name_uB); 7730 7731 -- Insert declaration of B in declarations of existing block 7732 7733 Prepend_To (Decls, 7734 Make_Object_Declaration (Loc, 7735 Defining_Identifier => B, 7736 Object_Definition => 7737 New_Occurrence_Of (Standard_Boolean, Loc))); 7738 7739 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC); 7740 7741 -- Insert the declaration of C in the declarations of the existing 7742 -- block. The variable is initialized to something (True or False, 7743 -- does not matter) to prevent CodePeer from complaining about a 7744 -- possible read of an uninitialized variable. 7745 7746 Prepend_To (Decls, 7747 Make_Object_Declaration (Loc, 7748 Defining_Identifier => Cancel_Param, 7749 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 7750 Expression => New_Occurrence_Of (Standard_False, Loc), 7751 Has_Init_Expression => True)); 7752 7753 -- Remove and save the call to Call_Simple 7754 7755 Stmt := First (Stmts); 7756 7757 -- Skip assignments to temporaries created for in-out parameters. 7758 -- This makes unwarranted assumptions about the shape of the expanded 7759 -- tree for the call, and should be cleaned up ??? 7760 7761 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7762 Next (Stmt); 7763 end loop; 7764 7765 Call := Stmt; 7766 7767 -- Create the inner block to protect the abortable part 7768 7769 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7770 7771 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7772 7773 Abortable_Block := 7774 Make_Block_Statement (Loc, 7775 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7776 Handled_Statement_Sequence => 7777 Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats), 7778 Has_Created_Identifier => True, 7779 Is_Asynchronous_Call_Block => True); 7780 7781 Insert_After (Call, 7782 Make_Block_Statement (Loc, 7783 Handled_Statement_Sequence => 7784 Make_Handled_Sequence_Of_Statements (Loc, 7785 Statements => New_List ( 7786 Make_Implicit_Label_Declaration (Loc, 7787 Defining_Identifier => Blk_Ent, 7788 Label_Construct => Abortable_Block), 7789 Abortable_Block), 7790 Exception_Handlers => Hdle))); 7791 7792 -- Create new call statement 7793 7794 Params := Parameter_Associations (Call); 7795 7796 Append_To (Params, 7797 New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7798 Append_To (Params, New_Occurrence_Of (B, Loc)); 7799 7800 Rewrite (Call, 7801 Make_Procedure_Call_Statement (Loc, 7802 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 7803 Parameter_Associations => Params)); 7804 7805 -- Construct statement sequence for new block 7806 7807 Append_To (Stmts, 7808 Make_Implicit_If_Statement (N, 7809 Condition => 7810 Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)), 7811 Then_Statements => Tstats)); 7812 7813 -- Protected the call against abort 7814 7815 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 7816 end if; 7817 7818 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param); 7819 7820 -- The result is the new block 7821 7822 Rewrite (N_Orig, 7823 Make_Block_Statement (Loc, 7824 Declarations => Decls, 7825 Handled_Statement_Sequence => 7826 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7827 7828 Analyze (N_Orig); 7829 end Expand_N_Asynchronous_Select; 7830 7831 ------------------------------------- 7832 -- Expand_N_Conditional_Entry_Call -- 7833 ------------------------------------- 7834 7835 -- The conditional task entry call is converted to a call to 7836 -- Task_Entry_Call: 7837 7838 -- declare 7839 -- B : Boolean; 7840 -- P : parms := (parm, parm, parm); 7841 7842 -- begin 7843 -- Task_Entry_Call 7844 -- (<acceptor-task>, -- Acceptor 7845 -- <entry-index>, -- E 7846 -- P'Address, -- Uninterpreted_Data 7847 -- Conditional_Call, -- Mode 7848 -- B); -- Rendezvous_Successful 7849 -- parm := P.param; 7850 -- parm := P.param; 7851 -- ... 7852 -- if B then 7853 -- normal-statements 7854 -- else 7855 -- else-statements 7856 -- end if; 7857 -- end; 7858 7859 -- For a description of the use of P and the assignments after the call, 7860 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the 7861 -- conditional entry call has already been expanded (by the Expand_N_Entry 7862 -- _Call_Statement procedure) as follows: 7863 7864 -- declare 7865 -- P : parms := (parm, parm, parm); 7866 -- begin 7867 -- ... info for in-out parameters 7868 -- Call_Simple (acceptor-task, entry-index, P'Address); 7869 -- parm := P.param; 7870 -- parm := P.param; 7871 -- ... 7872 -- end; 7873 7874 -- so the task at hand is to convert the latter expansion into the former 7875 7876 -- The conditional protected entry call is converted to a call to 7877 -- Protected_Entry_Call: 7878 7879 -- declare 7880 -- P : parms := (parm, parm, parm); 7881 -- Bnn : Communications_Block; 7882 7883 -- begin 7884 -- Protected_Entry_Call 7885 -- (po._object'Access, -- Object 7886 -- <entry index>, -- E 7887 -- P'Address, -- Uninterpreted_Data 7888 -- Conditional_Call, -- Mode 7889 -- Bnn); -- Block 7890 -- parm := P.param; 7891 -- parm := P.param; 7892 -- ... 7893 -- if Cancelled (Bnn) then 7894 -- else-statements 7895 -- else 7896 -- normal-statements 7897 -- end if; 7898 -- end; 7899 7900 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted 7901 -- into: 7902 7903 -- declare 7904 -- B : Boolean := False; 7905 -- C : Ada.Tags.Prim_Op_Kind; 7906 -- K : Ada.Tags.Tagged_Kind := 7907 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7908 -- P : Parameters := (Param1 .. ParamN); 7909 -- S : Integer; 7910 7911 -- begin 7912 -- if K = Ada.Tags.TK_Limited_Tagged 7913 -- or else K = Ada.Tags.TK_Tagged 7914 -- then 7915 -- <dispatching-call>; 7916 -- <triggering-statements> 7917 7918 -- else 7919 -- S := 7920 -- Ada.Tags.Get_Offset_Index 7921 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 7922 7923 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 7924 7925 -- if C = POK_Protected_Entry 7926 -- or else C = POK_Task_Entry 7927 -- then 7928 -- Param1 := P.Param1; 7929 -- ... 7930 -- ParamN := P.ParamN; 7931 -- end if; 7932 7933 -- if B then 7934 -- if C = POK_Procedure 7935 -- or else C = POK_Protected_Procedure 7936 -- or else C = POK_Task_Procedure 7937 -- then 7938 -- <dispatching-call>; 7939 -- end if; 7940 7941 -- <triggering-statements> 7942 -- else 7943 -- <else-statements> 7944 -- end if; 7945 -- end if; 7946 -- end; 7947 7948 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is 7949 Loc : constant Source_Ptr := Sloc (N); 7950 Alt : constant Node_Id := Entry_Call_Alternative (N); 7951 Blk : Node_Id := Entry_Call_Statement (Alt); 7952 7953 Actuals : List_Id; 7954 Blk_Typ : Entity_Id; 7955 Call : Node_Id; 7956 Call_Ent : Entity_Id; 7957 Conc_Typ_Stmts : List_Id; 7958 Decl : Node_Id; 7959 Decls : List_Id; 7960 Formals : List_Id; 7961 Lim_Typ_Stmts : List_Id; 7962 N_Stats : List_Id; 7963 Obj : Entity_Id; 7964 Param : Node_Id; 7965 Params : List_Id; 7966 Stmt : Node_Id; 7967 Stmts : List_Id; 7968 Transient_Blk : Node_Id; 7969 Unpack : List_Id; 7970 7971 B : Entity_Id; -- Call status flag 7972 C : Entity_Id; -- Call kind 7973 K : Entity_Id; -- Tagged kind 7974 P : Entity_Id; -- Parameter block 7975 S : Entity_Id; -- Primitive operation slot 7976 7977 begin 7978 Process_Statements_For_Controlled_Objects (N); 7979 7980 if Ada_Version >= Ada_2005 7981 and then Nkind (Blk) = N_Procedure_Call_Statement 7982 then 7983 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals); 7984 7985 Decls := New_List; 7986 Stmts := New_List; 7987 7988 -- Call status flag processing, generate: 7989 -- B : Boolean := False; 7990 7991 B := Build_B (Loc, Decls); 7992 7993 -- Call kind processing, generate: 7994 -- C : Ada.Tags.Prim_Op_Kind; 7995 7996 C := Build_C (Loc, Decls); 7997 7998 -- Tagged kind processing, generate: 7999 -- K : Ada.Tags.Tagged_Kind := 8000 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 8001 8002 K := Build_K (Loc, Decls, Obj); 8003 8004 -- Parameter block processing 8005 8006 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 8007 P := Parameter_Block_Pack 8008 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 8009 8010 -- Dispatch table slot processing, generate: 8011 -- S : Integer; 8012 8013 S := Build_S (Loc, Decls); 8014 8015 -- Generate: 8016 -- S := Ada.Tags.Get_Offset_Index 8017 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 8018 8019 Conc_Typ_Stmts := 8020 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 8021 8022 -- Generate: 8023 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 8024 8025 Append_To (Conc_Typ_Stmts, 8026 Make_Procedure_Call_Statement (Loc, 8027 Name => 8028 New_Occurrence_Of ( 8029 Find_Prim_Op (Etype (Etype (Obj)), 8030 Name_uDisp_Conditional_Select), 8031 Loc), 8032 Parameter_Associations => 8033 New_List ( 8034 New_Copy_Tree (Obj), -- <object> 8035 New_Occurrence_Of (S, Loc), -- S 8036 Make_Attribute_Reference (Loc, -- P'Address 8037 Prefix => New_Occurrence_Of (P, Loc), 8038 Attribute_Name => Name_Address), 8039 New_Occurrence_Of (C, Loc), -- C 8040 New_Occurrence_Of (B, Loc)))); -- B 8041 8042 -- Generate: 8043 -- if C = POK_Protected_Entry 8044 -- or else C = POK_Task_Entry 8045 -- then 8046 -- Param1 := P.Param1; 8047 -- ... 8048 -- ParamN := P.ParamN; 8049 -- end if; 8050 8051 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 8052 8053 -- Generate the if statement only when the packed parameters need 8054 -- explicit assignments to their corresponding actuals. 8055 8056 if Present (Unpack) then 8057 Append_To (Conc_Typ_Stmts, 8058 Make_Implicit_If_Statement (N, 8059 Condition => 8060 Make_Or_Else (Loc, 8061 Left_Opnd => 8062 Make_Op_Eq (Loc, 8063 Left_Opnd => 8064 New_Occurrence_Of (C, Loc), 8065 Right_Opnd => 8066 New_Occurrence_Of (RTE ( 8067 RE_POK_Protected_Entry), Loc)), 8068 8069 Right_Opnd => 8070 Make_Op_Eq (Loc, 8071 Left_Opnd => 8072 New_Occurrence_Of (C, Loc), 8073 Right_Opnd => 8074 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 8075 8076 Then_Statements => Unpack)); 8077 end if; 8078 8079 -- Generate: 8080 -- if B then 8081 -- if C = POK_Procedure 8082 -- or else C = POK_Protected_Procedure 8083 -- or else C = POK_Task_Procedure 8084 -- then 8085 -- <dispatching-call> 8086 -- end if; 8087 -- <normal-statements> 8088 -- else 8089 -- <else-statements> 8090 -- end if; 8091 8092 N_Stats := New_Copy_List_Tree (Statements (Alt)); 8093 8094 Prepend_To (N_Stats, 8095 Make_Implicit_If_Statement (N, 8096 Condition => 8097 Make_Or_Else (Loc, 8098 Left_Opnd => 8099 Make_Op_Eq (Loc, 8100 Left_Opnd => 8101 New_Occurrence_Of (C, Loc), 8102 Right_Opnd => 8103 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 8104 8105 Right_Opnd => 8106 Make_Or_Else (Loc, 8107 Left_Opnd => 8108 Make_Op_Eq (Loc, 8109 Left_Opnd => 8110 New_Occurrence_Of (C, Loc), 8111 Right_Opnd => 8112 New_Occurrence_Of (RTE ( 8113 RE_POK_Protected_Procedure), Loc)), 8114 8115 Right_Opnd => 8116 Make_Op_Eq (Loc, 8117 Left_Opnd => 8118 New_Occurrence_Of (C, Loc), 8119 Right_Opnd => 8120 New_Occurrence_Of (RTE ( 8121 RE_POK_Task_Procedure), Loc)))), 8122 8123 Then_Statements => 8124 New_List (Blk))); 8125 8126 Append_To (Conc_Typ_Stmts, 8127 Make_Implicit_If_Statement (N, 8128 Condition => New_Occurrence_Of (B, Loc), 8129 Then_Statements => N_Stats, 8130 Else_Statements => Else_Statements (N))); 8131 8132 -- Generate: 8133 -- <dispatching-call>; 8134 -- <triggering-statements> 8135 8136 Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt)); 8137 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); 8138 8139 -- Generate: 8140 -- if K = Ada.Tags.TK_Limited_Tagged 8141 -- or else K = Ada.Tags.TK_Tagged 8142 -- then 8143 -- Lim_Typ_Stmts 8144 -- else 8145 -- Conc_Typ_Stmts 8146 -- end if; 8147 8148 Append_To (Stmts, 8149 Make_Implicit_If_Statement (N, 8150 Condition => Build_Dispatching_Tag_Check (K, N), 8151 Then_Statements => Lim_Typ_Stmts, 8152 Else_Statements => Conc_Typ_Stmts)); 8153 8154 Rewrite (N, 8155 Make_Block_Statement (Loc, 8156 Declarations => 8157 Decls, 8158 Handled_Statement_Sequence => 8159 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8160 8161 -- As described above, the entry alternative is transformed into a 8162 -- block that contains the gnulli call, and possibly assignment 8163 -- statements for in-out parameters. The gnulli call may itself be 8164 -- rewritten into a transient block if some unconstrained parameters 8165 -- require it. We need to retrieve the call to complete its parameter 8166 -- list. 8167 8168 else 8169 Transient_Blk := 8170 First_Real_Statement (Handled_Statement_Sequence (Blk)); 8171 8172 if Present (Transient_Blk) 8173 and then Nkind (Transient_Blk) = N_Block_Statement 8174 then 8175 Blk := Transient_Blk; 8176 end if; 8177 8178 Stmts := Statements (Handled_Statement_Sequence (Blk)); 8179 Stmt := First (Stmts); 8180 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 8181 Next (Stmt); 8182 end loop; 8183 8184 Call := Stmt; 8185 Params := Parameter_Associations (Call); 8186 8187 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then 8188 8189 -- Substitute Conditional_Entry_Call for Simple_Call parameter 8190 8191 Param := First (Params); 8192 while Present (Param) 8193 and then not Is_RTE (Etype (Param), RE_Call_Modes) 8194 loop 8195 Next (Param); 8196 end loop; 8197 8198 pragma Assert (Present (Param)); 8199 Rewrite (Param, 8200 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8201 8202 Analyze (Param); 8203 8204 -- Find the Communication_Block parameter for the call to the 8205 -- Cancelled function. 8206 8207 Decl := First (Declarations (Blk)); 8208 while Present (Decl) 8209 and then not Is_RTE (Etype (Object_Definition (Decl)), 8210 RE_Communication_Block) 8211 loop 8212 Next (Decl); 8213 end loop; 8214 8215 -- Add an if statement to execute the else part if the call 8216 -- does not succeed (as indicated by the Cancelled predicate). 8217 8218 Append_To (Stmts, 8219 Make_Implicit_If_Statement (N, 8220 Condition => Make_Function_Call (Loc, 8221 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 8222 Parameter_Associations => New_List ( 8223 New_Occurrence_Of (Defining_Identifier (Decl), Loc))), 8224 Then_Statements => Else_Statements (N), 8225 Else_Statements => Statements (Alt))); 8226 8227 else 8228 B := Make_Defining_Identifier (Loc, Name_uB); 8229 8230 -- Insert declaration of B in declarations of existing block 8231 8232 if No (Declarations (Blk)) then 8233 Set_Declarations (Blk, New_List); 8234 end if; 8235 8236 Prepend_To (Declarations (Blk), 8237 Make_Object_Declaration (Loc, 8238 Defining_Identifier => B, 8239 Object_Definition => 8240 New_Occurrence_Of (Standard_Boolean, Loc))); 8241 8242 -- Create new call statement 8243 8244 Append_To (Params, 8245 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8246 Append_To (Params, New_Occurrence_Of (B, Loc)); 8247 8248 Rewrite (Call, 8249 Make_Procedure_Call_Statement (Loc, 8250 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 8251 Parameter_Associations => Params)); 8252 8253 -- Construct statement sequence for new block 8254 8255 Append_To (Stmts, 8256 Make_Implicit_If_Statement (N, 8257 Condition => New_Occurrence_Of (B, Loc), 8258 Then_Statements => Statements (Alt), 8259 Else_Statements => Else_Statements (N))); 8260 end if; 8261 8262 -- The result is the new block 8263 8264 Rewrite (N, 8265 Make_Block_Statement (Loc, 8266 Declarations => Declarations (Blk), 8267 Handled_Statement_Sequence => 8268 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8269 end if; 8270 8271 Analyze (N); 8272 8273 Reset_Scopes_To (N, Entity (Identifier (N))); 8274 end Expand_N_Conditional_Entry_Call; 8275 8276 --------------------------------------- 8277 -- Expand_N_Delay_Relative_Statement -- 8278 --------------------------------------- 8279 8280 -- Delay statement is implemented as a procedure call to Delay_For 8281 -- defined in Ada.Calendar.Delays in order to reduce the overhead of 8282 -- simple delays imposed by the use of Protected Objects. 8283 8284 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is 8285 Loc : constant Source_Ptr := Sloc (N); 8286 Proc : Entity_Id; 8287 8288 begin 8289 -- Try to use Ada.Calendar.Delays.Delay_For if available. 8290 8291 if RTE_Available (RO_CA_Delay_For) then 8292 Proc := RTE (RO_CA_Delay_For); 8293 8294 -- Otherwise, use System.Relative_Delays.Delay_For and emit an error 8295 -- message if not available. This is the implementation used on 8296 -- restricted platforms when Ada.Calendar is not available. 8297 8298 else 8299 Proc := RTE (RO_RD_Delay_For); 8300 end if; 8301 8302 Rewrite (N, 8303 Make_Procedure_Call_Statement (Loc, 8304 Name => New_Occurrence_Of (Proc, Loc), 8305 Parameter_Associations => New_List (Expression (N)))); 8306 Analyze (N); 8307 end Expand_N_Delay_Relative_Statement; 8308 8309 ------------------------------------ 8310 -- Expand_N_Delay_Until_Statement -- 8311 ------------------------------------ 8312 8313 -- Delay Until statement is implemented as a procedure call to 8314 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays. 8315 8316 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is 8317 Loc : constant Source_Ptr := Sloc (N); 8318 Typ : Entity_Id; 8319 8320 begin 8321 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then 8322 Typ := RTE (RO_CA_Delay_Until); 8323 else 8324 Typ := RTE (RO_RT_Delay_Until); 8325 end if; 8326 8327 Rewrite (N, 8328 Make_Procedure_Call_Statement (Loc, 8329 Name => New_Occurrence_Of (Typ, Loc), 8330 Parameter_Associations => New_List (Expression (N)))); 8331 8332 Analyze (N); 8333 end Expand_N_Delay_Until_Statement; 8334 8335 ------------------------- 8336 -- Expand_N_Entry_Body -- 8337 ------------------------- 8338 8339 procedure Expand_N_Entry_Body (N : Node_Id) is 8340 begin 8341 -- Associate discriminals with the next protected operation body to be 8342 -- expanded. 8343 8344 if Present (Next_Protected_Operation (N)) then 8345 Set_Discriminals (Parent (Current_Scope)); 8346 end if; 8347 end Expand_N_Entry_Body; 8348 8349 ----------------------------------- 8350 -- Expand_N_Entry_Call_Statement -- 8351 ----------------------------------- 8352 8353 -- An entry call is expanded into GNARLI calls to implement a simple entry 8354 -- call (see Build_Simple_Entry_Call). 8355 8356 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is 8357 Concval : Node_Id; 8358 Ename : Node_Id; 8359 Index : Node_Id; 8360 8361 begin 8362 if No_Run_Time_Mode then 8363 Error_Msg_CRT ("entry call", N); 8364 return; 8365 end if; 8366 8367 -- If this entry call is part of an asynchronous select, don't expand it 8368 -- here; it will be expanded with the select statement. Don't expand 8369 -- timed entry calls either, as they are translated into asynchronous 8370 -- entry calls. 8371 8372 -- ??? This whole approach is questionable; it may be better to go back 8373 -- to allowing the expansion to take place and then attempting to fix it 8374 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out 8375 -- whether the expanded call is on a task or protected entry. 8376 8377 if (Nkind (Parent (N)) /= N_Triggering_Alternative 8378 or else N /= Triggering_Statement (Parent (N))) 8379 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative 8380 or else N /= Entry_Call_Statement (Parent (N)) 8381 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call) 8382 then 8383 Extract_Entry (N, Concval, Ename, Index); 8384 Build_Simple_Entry_Call (N, Concval, Ename, Index); 8385 end if; 8386 end Expand_N_Entry_Call_Statement; 8387 8388 -------------------------------- 8389 -- Expand_N_Entry_Declaration -- 8390 -------------------------------- 8391 8392 -- If there are parameters, then first, each of the formals is marked by 8393 -- setting Is_Entry_Formal. Next a record type is built which is used to 8394 -- hold the parameter values. The name of this record type is entryP where 8395 -- entry is the name of the entry, with an additional corresponding access 8396 -- type called entryPA. The record type has matching components for each 8397 -- formal (the component names are the same as the formal names). For 8398 -- elementary types, the component type matches the formal type. For 8399 -- composite types, an access type is declared (with the name formalA) 8400 -- which designates the formal type, and the type of the component is this 8401 -- access type. Finally the Entry_Component of each formal is set to 8402 -- reference the corresponding record component. 8403 8404 procedure Expand_N_Entry_Declaration (N : Node_Id) is 8405 Loc : constant Source_Ptr := Sloc (N); 8406 Entry_Ent : constant Entity_Id := Defining_Identifier (N); 8407 Components : List_Id; 8408 Formal : Node_Id; 8409 Ftype : Entity_Id; 8410 Last_Decl : Node_Id; 8411 Component : Entity_Id; 8412 Ctype : Entity_Id; 8413 Decl : Node_Id; 8414 Rec_Ent : Entity_Id; 8415 Acc_Ent : Entity_Id; 8416 8417 begin 8418 Formal := First_Formal (Entry_Ent); 8419 Last_Decl := N; 8420 8421 -- Most processing is done only if parameters are present 8422 8423 if Present (Formal) then 8424 Components := New_List; 8425 8426 -- Loop through formals 8427 8428 while Present (Formal) loop 8429 Set_Is_Entry_Formal (Formal); 8430 Component := 8431 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); 8432 Set_Entry_Component (Formal, Component); 8433 Set_Entry_Formal (Component, Formal); 8434 Ftype := Etype (Formal); 8435 8436 -- Declare new access type and then append 8437 8438 Ctype := Make_Temporary (Loc, 'A'); 8439 Set_Is_Param_Block_Component_Type (Ctype); 8440 8441 Decl := 8442 Make_Full_Type_Declaration (Loc, 8443 Defining_Identifier => Ctype, 8444 Type_Definition => 8445 Make_Access_To_Object_Definition (Loc, 8446 All_Present => True, 8447 Constant_Present => Ekind (Formal) = E_In_Parameter, 8448 Subtype_Indication => New_Occurrence_Of (Ftype, Loc))); 8449 8450 Insert_After (Last_Decl, Decl); 8451 Last_Decl := Decl; 8452 8453 Append_To (Components, 8454 Make_Component_Declaration (Loc, 8455 Defining_Identifier => Component, 8456 Component_Definition => 8457 Make_Component_Definition (Loc, 8458 Aliased_Present => False, 8459 Subtype_Indication => New_Occurrence_Of (Ctype, Loc)))); 8460 8461 Next_Formal_With_Extras (Formal); 8462 end loop; 8463 8464 -- Create the Entry_Parameter_Record declaration 8465 8466 Rec_Ent := Make_Temporary (Loc, 'P'); 8467 8468 Decl := 8469 Make_Full_Type_Declaration (Loc, 8470 Defining_Identifier => Rec_Ent, 8471 Type_Definition => 8472 Make_Record_Definition (Loc, 8473 Component_List => 8474 Make_Component_List (Loc, 8475 Component_Items => Components))); 8476 8477 Insert_After (Last_Decl, Decl); 8478 Last_Decl := Decl; 8479 8480 -- Construct and link in the corresponding access type 8481 8482 Acc_Ent := Make_Temporary (Loc, 'A'); 8483 8484 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); 8485 8486 Decl := 8487 Make_Full_Type_Declaration (Loc, 8488 Defining_Identifier => Acc_Ent, 8489 Type_Definition => 8490 Make_Access_To_Object_Definition (Loc, 8491 All_Present => True, 8492 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc))); 8493 8494 Insert_After (Last_Decl, Decl); 8495 end if; 8496 end Expand_N_Entry_Declaration; 8497 8498 ----------------------------- 8499 -- Expand_N_Protected_Body -- 8500 ----------------------------- 8501 8502 -- Protected bodies are expanded to the completion of the subprograms 8503 -- created for the corresponding protected type. These are a protected and 8504 -- unprotected version of each protected subprogram in the object, a 8505 -- function to calculate each entry barrier, and a procedure to execute the 8506 -- sequence of statements of each protected entry body. For example, for 8507 -- protected type ptype: 8508 8509 -- function entB 8510 -- (O : System.Address; 8511 -- E : Protected_Entry_Index) 8512 -- return Boolean 8513 -- is 8514 -- <discriminant renamings> 8515 -- <private object renamings> 8516 -- begin 8517 -- return <barrier expression>; 8518 -- end entB; 8519 8520 -- procedure pprocN (_object : in out poV;...) is 8521 -- <discriminant renamings> 8522 -- <private object renamings> 8523 -- begin 8524 -- <sequence of statements> 8525 -- end pprocN; 8526 8527 -- procedure pprocP (_object : in out poV;...) is 8528 -- procedure _clean is 8529 -- Pn : Boolean; 8530 -- begin 8531 -- ptypeS (_object, Pn); 8532 -- Unlock (_object._object'Access); 8533 -- Abort_Undefer.all; 8534 -- end _clean; 8535 8536 -- begin 8537 -- Abort_Defer.all; 8538 -- Lock (_object._object'Access); 8539 -- pprocN (_object;...); 8540 -- at end 8541 -- _clean; 8542 -- end pproc; 8543 8544 -- function pfuncN (_object : poV;...) return Return_Type is 8545 -- <discriminant renamings> 8546 -- <private object renamings> 8547 -- begin 8548 -- <sequence of statements> 8549 -- end pfuncN; 8550 8551 -- function pfuncP (_object : poV) return Return_Type is 8552 -- procedure _clean is 8553 -- begin 8554 -- Unlock (_object._object'Access); 8555 -- Abort_Undefer.all; 8556 -- end _clean; 8557 8558 -- begin 8559 -- Abort_Defer.all; 8560 -- Lock (_object._object'Access); 8561 -- return pfuncN (_object); 8562 8563 -- at end 8564 -- _clean; 8565 -- end pfunc; 8566 8567 -- procedure entE 8568 -- (O : System.Address; 8569 -- P : System.Address; 8570 -- E : Protected_Entry_Index) 8571 -- is 8572 -- <discriminant renamings> 8573 -- <private object renamings> 8574 -- type poVP is access poV; 8575 -- _Object : ptVP := ptVP!(O); 8576 8577 -- begin 8578 -- begin 8579 -- <statement sequence> 8580 -- Complete_Entry_Body (_Object._Object); 8581 -- exception 8582 -- when all others => 8583 -- Exceptional_Complete_Entry_Body ( 8584 -- _Object._Object, Get_GNAT_Exception); 8585 -- end; 8586 -- end entE; 8587 8588 -- The type poV is the record created for the protected type to hold 8589 -- the state of the protected object. 8590 8591 procedure Expand_N_Protected_Body (N : Node_Id) is 8592 Loc : constant Source_Ptr := Sloc (N); 8593 Pid : constant Entity_Id := Corresponding_Spec (N); 8594 8595 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid); 8596 -- This flag indicates whether the lock free implementation is active 8597 8598 Current_Node : Node_Id; 8599 Disp_Op_Body : Node_Id; 8600 New_Op_Body : Node_Id; 8601 Op_Body : Node_Id; 8602 Op_Id : Entity_Id; 8603 8604 function Build_Dispatching_Subprogram_Body 8605 (N : Node_Id; 8606 Pid : Node_Id; 8607 Prot_Bod : Node_Id) return Node_Id; 8608 -- Build a dispatching version of the protected subprogram body. The 8609 -- newly generated subprogram contains a call to the original protected 8610 -- body. The following code is generated: 8611 -- 8612 -- function <protected-function-name> (Param1 .. ParamN) return 8613 -- <return-type> is 8614 -- begin 8615 -- return <protected-function-name>P (Param1 .. ParamN); 8616 -- end <protected-function-name>; 8617 -- 8618 -- or 8619 -- 8620 -- procedure <protected-procedure-name> (Param1 .. ParamN) is 8621 -- begin 8622 -- <protected-procedure-name>P (Param1 .. ParamN); 8623 -- end <protected-procedure-name> 8624 8625 --------------------------------------- 8626 -- Build_Dispatching_Subprogram_Body -- 8627 --------------------------------------- 8628 8629 function Build_Dispatching_Subprogram_Body 8630 (N : Node_Id; 8631 Pid : Node_Id; 8632 Prot_Bod : Node_Id) return Node_Id 8633 is 8634 Loc : constant Source_Ptr := Sloc (N); 8635 Actuals : List_Id; 8636 Formal : Node_Id; 8637 Spec : Node_Id; 8638 Stmts : List_Id; 8639 8640 begin 8641 -- Generate a specification without a letter suffix in order to 8642 -- override an interface function or procedure. 8643 8644 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode); 8645 8646 -- The formal parameters become the actuals of the protected function 8647 -- or procedure call. 8648 8649 Actuals := New_List; 8650 Formal := First (Parameter_Specifications (Spec)); 8651 while Present (Formal) loop 8652 Append_To (Actuals, 8653 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 8654 Next (Formal); 8655 end loop; 8656 8657 if Nkind (Spec) = N_Procedure_Specification then 8658 Stmts := 8659 New_List ( 8660 Make_Procedure_Call_Statement (Loc, 8661 Name => 8662 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8663 Parameter_Associations => Actuals)); 8664 8665 else 8666 pragma Assert (Nkind (Spec) = N_Function_Specification); 8667 8668 Stmts := 8669 New_List ( 8670 Make_Simple_Return_Statement (Loc, 8671 Expression => 8672 Make_Function_Call (Loc, 8673 Name => 8674 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8675 Parameter_Associations => Actuals))); 8676 end if; 8677 8678 return 8679 Make_Subprogram_Body (Loc, 8680 Declarations => Empty_List, 8681 Specification => Spec, 8682 Handled_Statement_Sequence => 8683 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 8684 end Build_Dispatching_Subprogram_Body; 8685 8686 -- Start of processing for Expand_N_Protected_Body 8687 8688 begin 8689 if No_Run_Time_Mode then 8690 Error_Msg_CRT ("protected body", N); 8691 return; 8692 end if; 8693 8694 -- This is the proper body corresponding to a stub. The declarations 8695 -- must be inserted at the point of the stub, which in turn is in the 8696 -- declarative part of the parent unit. 8697 8698 if Nkind (Parent (N)) = N_Subunit then 8699 Current_Node := Corresponding_Stub (Parent (N)); 8700 else 8701 Current_Node := N; 8702 end if; 8703 8704 Op_Body := First (Declarations (N)); 8705 8706 -- The protected body is replaced with the bodies of its protected 8707 -- operations, and the declarations for internal objects that may 8708 -- have been created for entry family bounds. 8709 8710 Rewrite (N, Make_Null_Statement (Sloc (N))); 8711 Analyze (N); 8712 8713 while Present (Op_Body) loop 8714 case Nkind (Op_Body) is 8715 when N_Subprogram_Declaration => 8716 null; 8717 8718 when N_Subprogram_Body => 8719 8720 -- Do not create bodies for eliminated operations 8721 8722 if not Is_Eliminated (Defining_Entity (Op_Body)) 8723 and then not Is_Eliminated (Corresponding_Spec (Op_Body)) 8724 then 8725 if Lock_Free_Active then 8726 New_Op_Body := 8727 Build_Lock_Free_Unprotected_Subprogram_Body 8728 (Op_Body, Pid); 8729 else 8730 New_Op_Body := 8731 Build_Unprotected_Subprogram_Body (Op_Body, Pid); 8732 end if; 8733 8734 Insert_After (Current_Node, New_Op_Body); 8735 Current_Node := New_Op_Body; 8736 Analyze (New_Op_Body); 8737 8738 -- Build the corresponding protected operation. It may 8739 -- appear that this is needed only if this is a visible 8740 -- operation of the type, or if it is an interrupt handler, 8741 -- and this was the strategy used previously in GNAT. 8742 8743 -- However, the operation may be exported through a 'Access 8744 -- to an external caller. This is the common idiom in code 8745 -- that uses the Ada 2005 Timing_Events package. As a result 8746 -- we need to produce the protected body for both visible 8747 -- and private operations, as well as operations that only 8748 -- have a body in the source, and for which we create a 8749 -- declaration in the protected body itself. 8750 8751 if Present (Corresponding_Spec (Op_Body)) then 8752 if Lock_Free_Active then 8753 New_Op_Body := 8754 Build_Lock_Free_Protected_Subprogram_Body 8755 (Op_Body, Pid, Specification (New_Op_Body)); 8756 else 8757 New_Op_Body := 8758 Build_Protected_Subprogram_Body 8759 (Op_Body, Pid, Specification (New_Op_Body)); 8760 end if; 8761 8762 Insert_After (Current_Node, New_Op_Body); 8763 Analyze (New_Op_Body); 8764 8765 Current_Node := New_Op_Body; 8766 8767 -- Generate an overriding primitive operation body for 8768 -- this subprogram if the protected type implements an 8769 -- interface. 8770 8771 if Ada_Version >= Ada_2005 8772 and then 8773 Present (Interfaces (Corresponding_Record_Type (Pid))) 8774 then 8775 Disp_Op_Body := 8776 Build_Dispatching_Subprogram_Body 8777 (Op_Body, Pid, New_Op_Body); 8778 8779 Insert_After (Current_Node, Disp_Op_Body); 8780 Analyze (Disp_Op_Body); 8781 8782 Current_Node := Disp_Op_Body; 8783 end if; 8784 end if; 8785 end if; 8786 8787 when N_Entry_Body => 8788 Op_Id := Defining_Identifier (Op_Body); 8789 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); 8790 8791 Insert_After (Current_Node, New_Op_Body); 8792 Current_Node := New_Op_Body; 8793 Analyze (New_Op_Body); 8794 8795 when N_Implicit_Label_Declaration => 8796 null; 8797 8798 when N_Call_Marker 8799 | N_Itype_Reference 8800 => 8801 New_Op_Body := New_Copy (Op_Body); 8802 Insert_After (Current_Node, New_Op_Body); 8803 Current_Node := New_Op_Body; 8804 8805 when N_Freeze_Entity => 8806 New_Op_Body := New_Copy (Op_Body); 8807 8808 if Present (Entity (Op_Body)) 8809 and then Freeze_Node (Entity (Op_Body)) = Op_Body 8810 then 8811 Set_Freeze_Node (Entity (Op_Body), New_Op_Body); 8812 end if; 8813 8814 Insert_After (Current_Node, New_Op_Body); 8815 Current_Node := New_Op_Body; 8816 Analyze (New_Op_Body); 8817 8818 when N_Pragma => 8819 New_Op_Body := New_Copy (Op_Body); 8820 Insert_After (Current_Node, New_Op_Body); 8821 Current_Node := New_Op_Body; 8822 Analyze (New_Op_Body); 8823 8824 when N_Object_Declaration => 8825 pragma Assert (not Comes_From_Source (Op_Body)); 8826 New_Op_Body := New_Copy (Op_Body); 8827 Insert_After (Current_Node, New_Op_Body); 8828 Current_Node := New_Op_Body; 8829 Analyze (New_Op_Body); 8830 8831 when others => 8832 raise Program_Error; 8833 end case; 8834 8835 Next (Op_Body); 8836 end loop; 8837 8838 -- Finally, create the body of the function that maps an entry index 8839 -- into the corresponding body index, except when there is no entry, or 8840 -- in a Ravenscar-like profile. 8841 8842 if Corresponding_Runtime_Package (Pid) = 8843 System_Tasking_Protected_Objects_Entries 8844 then 8845 New_Op_Body := Build_Find_Body_Index (Pid); 8846 Insert_After (Current_Node, New_Op_Body); 8847 Current_Node := New_Op_Body; 8848 Analyze (New_Op_Body); 8849 end if; 8850 8851 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the 8852 -- protected body. At this point all wrapper specs have been created, 8853 -- frozen and included in the dispatch table for the protected type. 8854 8855 if Ada_Version >= Ada_2005 then 8856 Build_Wrapper_Bodies (Loc, Pid, Current_Node); 8857 end if; 8858 end Expand_N_Protected_Body; 8859 8860 ----------------------------------------- 8861 -- Expand_N_Protected_Type_Declaration -- 8862 ----------------------------------------- 8863 8864 -- First we create a corresponding record type declaration used to 8865 -- represent values of this protected type. 8866 -- The general form of this type declaration is 8867 8868 -- type poV (discriminants) is record 8869 -- _Object : aliased <kind>Protection 8870 -- [(<entry count> [, <handler count>])]; 8871 -- [entry_family : array (bounds) of Void;] 8872 -- <private data fields> 8873 -- end record; 8874 8875 -- The discriminants are present only if the corresponding protected type 8876 -- has discriminants, and they exactly mirror the protected type 8877 -- discriminants. The private data fields similarly mirror the private 8878 -- declarations of the protected type. 8879 8880 -- The Object field is always present. It contains RTS specific data used 8881 -- to control the protected object. It is declared as Aliased so that it 8882 -- can be passed as a pointer to the RTS. This allows the protected record 8883 -- to be referenced within RTS data structures. An appropriate Protection 8884 -- type and discriminant are generated. 8885 8886 -- The Service field is present for protected objects with entries. It 8887 -- contains sufficient information to allow the entry service procedure for 8888 -- this object to be called when the object is not known till runtime. 8889 8890 -- One entry_family component is present for each entry family in the 8891 -- task definition (see Expand_N_Task_Type_Declaration). 8892 8893 -- When a protected object is declared, an instance of the protected type 8894 -- value record is created. The elaboration of this declaration creates the 8895 -- correct bounds for the entry families, and also evaluates the priority 8896 -- expression if needed. The initialization routine for the protected type 8897 -- itself then calls Initialize_Protection with appropriate parameters to 8898 -- initialize the value of the Task_Id field. Install_Handlers may be also 8899 -- called if a pragma Attach_Handler applies. 8900 8901 -- Note: this record is passed to the subprograms created by the expansion 8902 -- of protected subprograms and entries. It is an in parameter to protected 8903 -- functions and an in out parameter to procedures and entry bodies. The 8904 -- Entity_Id for this created record type is placed in the 8905 -- Corresponding_Record_Type field of the associated protected type entity. 8906 8907 -- Next we create a procedure specifications for protected subprograms and 8908 -- entry bodies. For each protected subprograms two subprograms are 8909 -- created, an unprotected and a protected version. The unprotected version 8910 -- is called from within other operations of the same protected object. 8911 8912 -- We also build the call to register the procedure if a pragma 8913 -- Interrupt_Handler applies. 8914 8915 -- A single subprogram is created to service all entry bodies; it has an 8916 -- additional boolean out parameter indicating that the previous entry call 8917 -- made by the current task was serviced immediately, i.e. not by proxy. 8918 -- The O parameter contains a pointer to a record object of the type 8919 -- described above. An untyped interface is used here to allow this 8920 -- procedure to be called in places where the type of the object to be 8921 -- serviced is not known. This must be done, for example, when a call that 8922 -- may have been requeued is cancelled; the corresponding object must be 8923 -- serviced, but which object that is not known till runtime. 8924 8925 -- procedure ptypeS 8926 -- (O : System.Address; P : out Boolean); 8927 -- procedure pprocN (_object : in out poV); 8928 -- procedure pproc (_object : in out poV); 8929 -- function pfuncN (_object : poV); 8930 -- function pfunc (_object : poV); 8931 -- ... 8932 8933 -- Note that this must come after the record type declaration, since 8934 -- the specs refer to this type. 8935 8936 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is 8937 Discr_Map : constant Elist_Id := New_Elmt_List; 8938 Loc : constant Source_Ptr := Sloc (N); 8939 Prot_Typ : constant Entity_Id := Defining_Identifier (N); 8940 8941 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ); 8942 -- This flag indicates whether the lock free implementation is active 8943 8944 Pdef : constant Node_Id := Protected_Definition (N); 8945 -- This contains two lists; one for visible and one for private decls 8946 8947 Current_Node : Node_Id := N; 8948 E_Count : Int; 8949 Entries_Aggr : Node_Id; 8950 Rec_Decl : Node_Id; 8951 Rec_Id : Entity_Id; 8952 8953 procedure Check_Inlining (Subp : Entity_Id); 8954 -- If the original operation has a pragma Inline, propagate the flag 8955 -- to the internal body, for possible inlining later on. The source 8956 -- operation is invisible to the back-end and is never actually called. 8957 8958 procedure Expand_Entry_Declaration (Decl : Node_Id); 8959 -- Create the entry barrier and the procedure body for entry declaration 8960 -- Decl. All generated subprograms are added to Entry_Bodies_Array. 8961 8962 function Static_Component_Size (Comp : Entity_Id) return Boolean; 8963 -- When compiling under the Ravenscar profile, private components must 8964 -- have a static size, or else a protected object will require heap 8965 -- allocation, violating the corresponding restriction. It is preferable 8966 -- to make this check here, because it provides a better error message 8967 -- than the back-end, which refers to the object as a whole. 8968 8969 procedure Register_Handler; 8970 -- For a protected operation that is an interrupt handler, add the 8971 -- freeze action that will register it as such. 8972 8973 procedure Replace_Access_Definition (Comp : Node_Id); 8974 -- If a private component of the type is an access to itself, this 8975 -- is not a reference to the current instance, but an access type out 8976 -- of which one might construct a list. If such a component exists, we 8977 -- create an incomplete type for the equivalent record type, and 8978 -- a named access type for it, that replaces the access definition 8979 -- of the original component. This is similar to what is done for 8980 -- records in Check_Anonymous_Access_Components, but simpler, because 8981 -- the corresponding record type has no previous declaration. 8982 -- This needs to be done only once, even if there are several such 8983 -- access components. The following entity stores the constructed 8984 -- access type. 8985 8986 Acc_T : Entity_Id := Empty; 8987 8988 -------------------- 8989 -- Check_Inlining -- 8990 -------------------- 8991 8992 procedure Check_Inlining (Subp : Entity_Id) is 8993 begin 8994 if Is_Inlined (Subp) then 8995 Set_Is_Inlined (Protected_Body_Subprogram (Subp)); 8996 Set_Is_Inlined (Subp, False); 8997 end if; 8998 8999 if Has_Pragma_No_Inline (Subp) then 9000 Set_Has_Pragma_No_Inline (Protected_Body_Subprogram (Subp)); 9001 end if; 9002 end Check_Inlining; 9003 9004 --------------------------- 9005 -- Static_Component_Size -- 9006 --------------------------- 9007 9008 function Static_Component_Size (Comp : Entity_Id) return Boolean is 9009 Typ : constant Entity_Id := Etype (Comp); 9010 C : Entity_Id; 9011 9012 begin 9013 if Is_Scalar_Type (Typ) then 9014 return True; 9015 9016 elsif Is_Array_Type (Typ) then 9017 return Compile_Time_Known_Bounds (Typ); 9018 9019 elsif Is_Record_Type (Typ) then 9020 C := First_Component (Typ); 9021 while Present (C) loop 9022 if not Static_Component_Size (C) then 9023 return False; 9024 end if; 9025 9026 Next_Component (C); 9027 end loop; 9028 9029 return True; 9030 9031 -- Any other type will be checked by the back-end 9032 9033 else 9034 return True; 9035 end if; 9036 end Static_Component_Size; 9037 9038 ------------------------------ 9039 -- Expand_Entry_Declaration -- 9040 ------------------------------ 9041 9042 procedure Expand_Entry_Declaration (Decl : Node_Id) is 9043 Ent_Id : constant Entity_Id := Defining_Entity (Decl); 9044 Bar_Id : Entity_Id; 9045 Bod_Id : Entity_Id; 9046 Subp : Node_Id; 9047 9048 begin 9049 E_Count := E_Count + 1; 9050 9051 -- Create the protected body subprogram 9052 9053 Bod_Id := 9054 Make_Defining_Identifier (Loc, 9055 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E')); 9056 Set_Protected_Body_Subprogram (Ent_Id, Bod_Id); 9057 9058 Subp := 9059 Make_Subprogram_Declaration (Loc, 9060 Specification => 9061 Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id)); 9062 9063 Insert_After (Current_Node, Subp); 9064 Current_Node := Subp; 9065 9066 Analyze (Subp); 9067 9068 -- Build a wrapper procedure to handle contract cases, preconditions, 9069 -- and postconditions. 9070 9071 Build_Contract_Wrapper (Ent_Id, N); 9072 9073 -- Create the barrier function 9074 9075 Bar_Id := 9076 Make_Defining_Identifier (Loc, 9077 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B')); 9078 Set_Barrier_Function (Ent_Id, Bar_Id); 9079 9080 Subp := 9081 Make_Subprogram_Declaration (Loc, 9082 Specification => 9083 Build_Barrier_Function_Specification (Loc, Bar_Id)); 9084 Set_Is_Entry_Barrier_Function (Subp); 9085 9086 Insert_After (Current_Node, Subp); 9087 Current_Node := Subp; 9088 9089 Analyze (Subp); 9090 9091 Set_Protected_Body_Subprogram (Bar_Id, Bar_Id); 9092 Set_Scope (Bar_Id, Scope (Ent_Id)); 9093 9094 -- Collect pointers to the protected subprogram and the barrier 9095 -- of the current entry, for insertion into Entry_Bodies_Array. 9096 9097 Append_To (Expressions (Entries_Aggr), 9098 Make_Aggregate (Loc, 9099 Expressions => New_List ( 9100 Make_Attribute_Reference (Loc, 9101 Prefix => New_Occurrence_Of (Bar_Id, Loc), 9102 Attribute_Name => Name_Unrestricted_Access), 9103 Make_Attribute_Reference (Loc, 9104 Prefix => New_Occurrence_Of (Bod_Id, Loc), 9105 Attribute_Name => Name_Unrestricted_Access)))); 9106 end Expand_Entry_Declaration; 9107 9108 ---------------------- 9109 -- Register_Handler -- 9110 ---------------------- 9111 9112 procedure Register_Handler is 9113 9114 -- All semantic checks already done in Sem_Prag 9115 9116 Prot_Proc : constant Entity_Id := 9117 Defining_Unit_Name (Specification (Current_Node)); 9118 9119 Proc_Address : constant Node_Id := 9120 Make_Attribute_Reference (Loc, 9121 Prefix => 9122 New_Occurrence_Of (Prot_Proc, Loc), 9123 Attribute_Name => Name_Address); 9124 9125 RTS_Call : constant Entity_Id := 9126 Make_Procedure_Call_Statement (Loc, 9127 Name => 9128 New_Occurrence_Of 9129 (RTE (RE_Register_Interrupt_Handler), Loc), 9130 Parameter_Associations => New_List (Proc_Address)); 9131 begin 9132 Append_Freeze_Action (Prot_Proc, RTS_Call); 9133 end Register_Handler; 9134 9135 ------------------------------- 9136 -- Replace_Access_Definition -- 9137 ------------------------------- 9138 9139 procedure Replace_Access_Definition (Comp : Node_Id) is 9140 Loc : constant Source_Ptr := Sloc (Comp); 9141 Inc_T : Node_Id; 9142 Inc_D : Node_Id; 9143 Acc_Def : Node_Id; 9144 Acc_D : Node_Id; 9145 9146 begin 9147 if No (Acc_T) then 9148 Inc_T := Make_Defining_Identifier (Loc, Chars (Rec_Id)); 9149 Inc_D := Make_Incomplete_Type_Declaration (Loc, Inc_T); 9150 Acc_T := Make_Temporary (Loc, 'S'); 9151 Acc_Def := 9152 Make_Access_To_Object_Definition (Loc, 9153 Subtype_Indication => New_Occurrence_Of (Inc_T, Loc)); 9154 Acc_D := 9155 Make_Full_Type_Declaration (Loc, 9156 Defining_Identifier => Acc_T, 9157 Type_Definition => Acc_Def); 9158 9159 Insert_Before (Rec_Decl, Inc_D); 9160 Analyze (Inc_D); 9161 9162 Insert_Before (Rec_Decl, Acc_D); 9163 Analyze (Acc_D); 9164 end if; 9165 9166 Set_Access_Definition (Comp, Empty); 9167 Set_Subtype_Indication (Comp, New_Occurrence_Of (Acc_T, Loc)); 9168 end Replace_Access_Definition; 9169 9170 -- Local variables 9171 9172 Body_Arr : Node_Id; 9173 Body_Id : Entity_Id; 9174 Cdecls : List_Id; 9175 Comp : Node_Id; 9176 Expr : Node_Id; 9177 New_Priv : Node_Id; 9178 Obj_Def : Node_Id; 9179 Object_Comp : Node_Id; 9180 Priv : Node_Id; 9181 Sub : Node_Id; 9182 9183 -- Start of processing for Expand_N_Protected_Type_Declaration 9184 9185 begin 9186 if Present (Corresponding_Record_Type (Prot_Typ)) then 9187 return; 9188 else 9189 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); 9190 Rec_Id := Defining_Identifier (Rec_Decl); 9191 end if; 9192 9193 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); 9194 9195 Qualify_Entity_Names (N); 9196 9197 -- If the type has discriminants, their occurrences in the declaration 9198 -- have been replaced by the corresponding discriminals. For components 9199 -- that are constrained by discriminants, their homologues in the 9200 -- corresponding record type must refer to the discriminants of that 9201 -- record, so we must apply a new renaming to subtypes_indications: 9202 9203 -- protected discriminant => discriminal => record discriminant 9204 9205 -- This replacement is not applied to default expressions, for which 9206 -- the discriminal is correct. 9207 9208 if Has_Discriminants (Prot_Typ) then 9209 declare 9210 Disc : Entity_Id; 9211 Decl : Node_Id; 9212 9213 begin 9214 Disc := First_Discriminant (Prot_Typ); 9215 Decl := First (Discriminant_Specifications (Rec_Decl)); 9216 while Present (Disc) loop 9217 Append_Elmt (Discriminal (Disc), Discr_Map); 9218 Append_Elmt (Defining_Identifier (Decl), Discr_Map); 9219 Next_Discriminant (Disc); 9220 Next (Decl); 9221 end loop; 9222 end; 9223 end if; 9224 9225 -- Fill in the component declarations 9226 9227 -- Add components for entry families. For each entry family, create an 9228 -- anonymous type declaration with the same size, and analyze the type. 9229 9230 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); 9231 9232 pragma Assert (Present (Pdef)); 9233 9234 Insert_After (Current_Node, Rec_Decl); 9235 Current_Node := Rec_Decl; 9236 9237 -- Add private field components 9238 9239 if Present (Private_Declarations (Pdef)) then 9240 Priv := First (Private_Declarations (Pdef)); 9241 while Present (Priv) loop 9242 if Nkind (Priv) = N_Component_Declaration then 9243 if not Static_Component_Size (Defining_Identifier (Priv)) then 9244 9245 -- When compiling for a restricted profile, the private 9246 -- components must have a static size. If not, this is an 9247 -- error for a single protected declaration, and rates a 9248 -- warning on a protected type declaration. 9249 9250 if not Comes_From_Source (Prot_Typ) then 9251 9252 -- It's ok to be checking this restriction at expansion 9253 -- time, because this is only for the restricted profile, 9254 -- which is not subject to strict RM conformance, so it 9255 -- is OK to miss this check in -gnatc mode. 9256 9257 Check_Restriction (No_Implicit_Heap_Allocations, Priv); 9258 Check_Restriction 9259 (No_Implicit_Protected_Object_Allocations, Priv); 9260 9261 elsif Restriction_Active (No_Implicit_Heap_Allocations) then 9262 if not Discriminated_Size (Defining_Identifier (Priv)) 9263 then 9264 -- Any object of the type will be non-static 9265 9266 Error_Msg_N ("component has non-static size??", Priv); 9267 Error_Msg_NE 9268 ("\creation of protected object of type& will " 9269 & "violate restriction " 9270 & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ); 9271 else 9272 -- Object will be non-static if discriminants are 9273 9274 Error_Msg_NE 9275 ("creation of protected object of type& with " 9276 & "non-static discriminants will violate " 9277 & "restriction No_Implicit_Heap_Allocations??", 9278 Priv, Prot_Typ); 9279 end if; 9280 9281 -- Likewise for No_Implicit_Protected_Object_Allocations 9282 9283 elsif Restriction_Active 9284 (No_Implicit_Protected_Object_Allocations) 9285 then 9286 if not Discriminated_Size (Defining_Identifier (Priv)) 9287 then 9288 -- Any object of the type will be non-static 9289 9290 Error_Msg_N ("component has non-static size??", Priv); 9291 Error_Msg_NE 9292 ("\creation of protected object of type& will " 9293 & "violate restriction " 9294 & "No_Implicit_Protected_Object_Allocations??", 9295 Priv, Prot_Typ); 9296 else 9297 -- Object will be non-static if discriminants are 9298 9299 Error_Msg_NE 9300 ("creation of protected object of type& with " 9301 & "non-static discriminants will violate " 9302 & "restriction " 9303 & "No_Implicit_Protected_Object_Allocations??", 9304 Priv, Prot_Typ); 9305 end if; 9306 end if; 9307 end if; 9308 9309 -- The component definition consists of a subtype indication, 9310 -- or (in Ada 2005) an access definition. Make a copy of the 9311 -- proper definition. 9312 9313 declare 9314 Old_Comp : constant Node_Id := Component_Definition (Priv); 9315 Oent : constant Entity_Id := Defining_Identifier (Priv); 9316 Nent : constant Entity_Id := 9317 Make_Defining_Identifier (Sloc (Oent), 9318 Chars => Chars (Oent)); 9319 New_Comp : Node_Id; 9320 9321 begin 9322 if Present (Subtype_Indication (Old_Comp)) then 9323 New_Comp := 9324 Make_Component_Definition (Sloc (Oent), 9325 Aliased_Present => False, 9326 Subtype_Indication => 9327 New_Copy_Tree 9328 (Subtype_Indication (Old_Comp), Discr_Map)); 9329 else 9330 New_Comp := 9331 Make_Component_Definition (Sloc (Oent), 9332 Aliased_Present => False, 9333 Access_Definition => 9334 New_Copy_Tree 9335 (Access_Definition (Old_Comp), Discr_Map)); 9336 9337 -- A self-reference in the private part becomes a 9338 -- self-reference to the corresponding record. 9339 9340 if Entity (Subtype_Mark (Access_Definition (New_Comp))) 9341 = Prot_Typ 9342 then 9343 Replace_Access_Definition (New_Comp); 9344 end if; 9345 end if; 9346 9347 New_Priv := 9348 Make_Component_Declaration (Loc, 9349 Defining_Identifier => Nent, 9350 Component_Definition => New_Comp, 9351 Expression => Expression (Priv)); 9352 9353 Set_Has_Per_Object_Constraint (Nent, 9354 Has_Per_Object_Constraint (Oent)); 9355 9356 Append_To (Cdecls, New_Priv); 9357 end; 9358 9359 elsif Nkind (Priv) = N_Subprogram_Declaration then 9360 9361 -- Make the unprotected version of the subprogram available 9362 -- for expansion of intra object calls. There is need for 9363 -- a protected version only if the subprogram is an interrupt 9364 -- handler, otherwise this operation can only be called from 9365 -- within the body. 9366 9367 Sub := 9368 Make_Subprogram_Declaration (Loc, 9369 Specification => 9370 Build_Protected_Sub_Specification 9371 (Priv, Prot_Typ, Unprotected_Mode)); 9372 9373 Insert_After (Current_Node, Sub); 9374 Analyze (Sub); 9375 9376 Set_Protected_Body_Subprogram 9377 (Defining_Unit_Name (Specification (Priv)), 9378 Defining_Unit_Name (Specification (Sub))); 9379 Check_Inlining (Defining_Unit_Name (Specification (Priv))); 9380 Current_Node := Sub; 9381 9382 Sub := 9383 Make_Subprogram_Declaration (Loc, 9384 Specification => 9385 Build_Protected_Sub_Specification 9386 (Priv, Prot_Typ, Protected_Mode)); 9387 9388 Insert_After (Current_Node, Sub); 9389 Analyze (Sub); 9390 Current_Node := Sub; 9391 9392 if Is_Interrupt_Handler 9393 (Defining_Unit_Name (Specification (Priv))) 9394 then 9395 if not Restricted_Profile then 9396 Register_Handler; 9397 end if; 9398 end if; 9399 end if; 9400 9401 Next (Priv); 9402 end loop; 9403 end if; 9404 9405 -- Except for the lock-free implementation, append the _Object field 9406 -- with the right type to the component list. We need to compute the 9407 -- number of entries, and in some cases the number of Attach_Handler 9408 -- pragmas. 9409 9410 if not Lock_Free_Active then 9411 declare 9412 Entry_Count_Expr : constant Node_Id := 9413 Build_Entry_Count_Expression 9414 (Prot_Typ, Cdecls, Loc); 9415 Num_Attach_Handler : Nat := 0; 9416 Protection_Subtype : Node_Id; 9417 Ritem : Node_Id; 9418 9419 begin 9420 if Has_Attach_Handler (Prot_Typ) then 9421 Ritem := First_Rep_Item (Prot_Typ); 9422 while Present (Ritem) loop 9423 if Nkind (Ritem) = N_Pragma 9424 and then Pragma_Name (Ritem) = Name_Attach_Handler 9425 then 9426 Num_Attach_Handler := Num_Attach_Handler + 1; 9427 end if; 9428 9429 Next_Rep_Item (Ritem); 9430 end loop; 9431 end if; 9432 9433 -- Determine the proper protection type. There are two special 9434 -- cases: 1) when the protected type has dynamic interrupt 9435 -- handlers, and 2) when it has static handlers and we use a 9436 -- restricted profile. 9437 9438 if Has_Attach_Handler (Prot_Typ) 9439 and then not Restricted_Profile 9440 then 9441 Protection_Subtype := 9442 Make_Subtype_Indication (Loc, 9443 Subtype_Mark => 9444 New_Occurrence_Of 9445 (RTE (RE_Static_Interrupt_Protection), Loc), 9446 Constraint => 9447 Make_Index_Or_Discriminant_Constraint (Loc, 9448 Constraints => New_List ( 9449 Entry_Count_Expr, 9450 Make_Integer_Literal (Loc, Num_Attach_Handler)))); 9451 9452 elsif Has_Interrupt_Handler (Prot_Typ) 9453 and then not Restriction_Active (No_Dynamic_Attachment) 9454 then 9455 Protection_Subtype := 9456 Make_Subtype_Indication (Loc, 9457 Subtype_Mark => 9458 New_Occurrence_Of 9459 (RTE (RE_Dynamic_Interrupt_Protection), Loc), 9460 Constraint => 9461 Make_Index_Or_Discriminant_Constraint (Loc, 9462 Constraints => New_List (Entry_Count_Expr))); 9463 9464 else 9465 case Corresponding_Runtime_Package (Prot_Typ) is 9466 when System_Tasking_Protected_Objects_Entries => 9467 Protection_Subtype := 9468 Make_Subtype_Indication (Loc, 9469 Subtype_Mark => 9470 New_Occurrence_Of 9471 (RTE (RE_Protection_Entries), Loc), 9472 Constraint => 9473 Make_Index_Or_Discriminant_Constraint (Loc, 9474 Constraints => New_List (Entry_Count_Expr))); 9475 9476 when System_Tasking_Protected_Objects_Single_Entry => 9477 Protection_Subtype := 9478 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc); 9479 9480 when System_Tasking_Protected_Objects => 9481 Protection_Subtype := 9482 New_Occurrence_Of (RTE (RE_Protection), Loc); 9483 9484 when others => 9485 raise Program_Error; 9486 end case; 9487 end if; 9488 9489 Object_Comp := 9490 Make_Component_Declaration (Loc, 9491 Defining_Identifier => 9492 Make_Defining_Identifier (Loc, Name_uObject), 9493 Component_Definition => 9494 Make_Component_Definition (Loc, 9495 Aliased_Present => True, 9496 Subtype_Indication => Protection_Subtype)); 9497 end; 9498 9499 -- Put the _Object component after the private component so that it 9500 -- be finalized early as required by 9.4 (20) 9501 9502 Append_To (Cdecls, Object_Comp); 9503 end if; 9504 9505 -- Analyze the record declaration immediately after construction, 9506 -- because the initialization procedure is needed for single object 9507 -- declarations before the next entity is analyzed (the freeze call 9508 -- that generates this initialization procedure is found below). 9509 9510 Analyze (Rec_Decl, Suppress => All_Checks); 9511 9512 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before 9513 -- the corresponding record is frozen. If any wrappers are generated, 9514 -- Current_Node is updated accordingly. 9515 9516 if Ada_Version >= Ada_2005 then 9517 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node); 9518 end if; 9519 9520 -- Collect pointers to entry bodies and their barriers, to be placed 9521 -- in the Entry_Bodies_Array for the type. For each entry/family we 9522 -- add an expression to the aggregate which is the initial value of 9523 -- this array. The array is declared after all protected subprograms. 9524 9525 if Has_Entries (Prot_Typ) then 9526 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); 9527 else 9528 Entries_Aggr := Empty; 9529 end if; 9530 9531 -- Build two new procedure specifications for each protected subprogram; 9532 -- one to call from outside the object and one to call from inside. 9533 -- Build a barrier function and an entry body action procedure 9534 -- specification for each protected entry. Initialize the entry body 9535 -- array. If subprogram is flagged as eliminated, do not generate any 9536 -- internal operations. 9537 9538 E_Count := 0; 9539 Comp := First (Visible_Declarations (Pdef)); 9540 while Present (Comp) loop 9541 if Nkind (Comp) = N_Subprogram_Declaration then 9542 Sub := 9543 Make_Subprogram_Declaration (Loc, 9544 Specification => 9545 Build_Protected_Sub_Specification 9546 (Comp, Prot_Typ, Unprotected_Mode)); 9547 9548 Insert_After (Current_Node, Sub); 9549 Analyze (Sub); 9550 9551 Set_Protected_Body_Subprogram 9552 (Defining_Unit_Name (Specification (Comp)), 9553 Defining_Unit_Name (Specification (Sub))); 9554 Check_Inlining (Defining_Unit_Name (Specification (Comp))); 9555 9556 -- Make the protected version of the subprogram available for 9557 -- expansion of external calls. 9558 9559 Current_Node := Sub; 9560 9561 Sub := 9562 Make_Subprogram_Declaration (Loc, 9563 Specification => 9564 Build_Protected_Sub_Specification 9565 (Comp, Prot_Typ, Protected_Mode)); 9566 9567 Insert_After (Current_Node, Sub); 9568 Analyze (Sub); 9569 9570 Current_Node := Sub; 9571 9572 -- Generate an overriding primitive operation specification for 9573 -- this subprogram if the protected type implements an interface 9574 -- and Build_Wrapper_Spec did not generate its wrapper. 9575 9576 if Ada_Version >= Ada_2005 9577 and then 9578 Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) 9579 then 9580 declare 9581 Found : Boolean := False; 9582 Prim_Elmt : Elmt_Id; 9583 Prim_Op : Node_Id; 9584 9585 begin 9586 Prim_Elmt := 9587 First_Elmt 9588 (Primitive_Operations 9589 (Corresponding_Record_Type (Prot_Typ))); 9590 9591 while Present (Prim_Elmt) loop 9592 Prim_Op := Node (Prim_Elmt); 9593 9594 if Is_Primitive_Wrapper (Prim_Op) 9595 and then Wrapped_Entity (Prim_Op) = 9596 Defining_Entity (Specification (Comp)) 9597 then 9598 Found := True; 9599 exit; 9600 end if; 9601 9602 Next_Elmt (Prim_Elmt); 9603 end loop; 9604 9605 if not Found then 9606 Sub := 9607 Make_Subprogram_Declaration (Loc, 9608 Specification => 9609 Build_Protected_Sub_Specification 9610 (Comp, Prot_Typ, Dispatching_Mode)); 9611 9612 Insert_After (Current_Node, Sub); 9613 Analyze (Sub); 9614 9615 Current_Node := Sub; 9616 end if; 9617 end; 9618 end if; 9619 9620 -- If a pragma Interrupt_Handler applies, build and add a call to 9621 -- Register_Interrupt_Handler to the freezing actions of the 9622 -- protected version (Current_Node) of the subprogram: 9623 9624 -- system.interrupts.register_interrupt_handler 9625 -- (prot_procP'address); 9626 9627 if not Restricted_Profile 9628 and then Is_Interrupt_Handler 9629 (Defining_Unit_Name (Specification (Comp))) 9630 then 9631 Register_Handler; 9632 end if; 9633 9634 elsif Nkind (Comp) = N_Entry_Declaration then 9635 Expand_Entry_Declaration (Comp); 9636 end if; 9637 9638 Next (Comp); 9639 end loop; 9640 9641 -- If there are some private entry declarations, expand it as if they 9642 -- were visible entries. 9643 9644 if Present (Private_Declarations (Pdef)) then 9645 Comp := First (Private_Declarations (Pdef)); 9646 while Present (Comp) loop 9647 if Nkind (Comp) = N_Entry_Declaration then 9648 Expand_Entry_Declaration (Comp); 9649 end if; 9650 9651 Next (Comp); 9652 end loop; 9653 end if; 9654 9655 -- Create the declaration of an array object which contains the values 9656 -- of aspect/pragma Max_Queue_Length for all entries of the protected 9657 -- type. This object is later passed to the appropriate protected object 9658 -- initialization routine. 9659 9660 if Has_Entries (Prot_Typ) 9661 and then Corresponding_Runtime_Package (Prot_Typ) = 9662 System_Tasking_Protected_Objects_Entries 9663 then 9664 declare 9665 Count : Int; 9666 Item : Entity_Id; 9667 Max_Vals : Node_Id; 9668 Maxes : List_Id; 9669 Maxes_Id : Entity_Id; 9670 Need_Array : Boolean := False; 9671 9672 begin 9673 -- First check if there is any Max_Queue_Length pragma 9674 9675 Item := First_Entity (Prot_Typ); 9676 while Present (Item) loop 9677 if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then 9678 Need_Array := True; 9679 exit; 9680 end if; 9681 9682 Next_Entity (Item); 9683 end loop; 9684 9685 -- Gather the Max_Queue_Length values of all entries in a list. A 9686 -- value of zero indicates that the entry has no limitation on its 9687 -- queue length. 9688 9689 if Need_Array then 9690 Count := 0; 9691 Item := First_Entity (Prot_Typ); 9692 Maxes := New_List; 9693 while Present (Item) loop 9694 if Is_Entry (Item) then 9695 Count := Count + 1; 9696 Append_To (Maxes, 9697 Make_Integer_Literal 9698 (Loc, Get_Max_Queue_Length (Item))); 9699 end if; 9700 9701 Next_Entity (Item); 9702 end loop; 9703 9704 -- Create the declaration of the array object. Generate: 9705 9706 -- Maxes_Id : aliased constant 9707 -- Protected_Entry_Queue_Max_Array 9708 -- (1 .. Count) := (..., ...); 9709 9710 Maxes_Id := 9711 Make_Defining_Identifier (Loc, 9712 Chars => New_External_Name (Chars (Prot_Typ), 'B')); 9713 9714 Max_Vals := 9715 Make_Object_Declaration (Loc, 9716 Defining_Identifier => Maxes_Id, 9717 Aliased_Present => True, 9718 Constant_Present => True, 9719 Object_Definition => 9720 Make_Subtype_Indication (Loc, 9721 Subtype_Mark => 9722 New_Occurrence_Of 9723 (RTE (RE_Protected_Entry_Queue_Max_Array), Loc), 9724 Constraint => 9725 Make_Index_Or_Discriminant_Constraint (Loc, 9726 Constraints => New_List ( 9727 Make_Range (Loc, 9728 Make_Integer_Literal (Loc, 1), 9729 Make_Integer_Literal (Loc, Count))))), 9730 Expression => Make_Aggregate (Loc, Maxes)); 9731 9732 -- A pointer to this array will be placed in the corresponding 9733 -- record by its initialization procedure so this needs to be 9734 -- analyzed here. 9735 9736 Insert_After (Current_Node, Max_Vals); 9737 Current_Node := Max_Vals; 9738 Analyze (Max_Vals); 9739 9740 Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxes_Id); 9741 end if; 9742 end; 9743 end if; 9744 9745 -- Emit declaration for Entry_Bodies_Array, now that the addresses of 9746 -- all protected subprograms have been collected. 9747 9748 if Has_Entries (Prot_Typ) then 9749 Body_Id := 9750 Make_Defining_Identifier (Sloc (Prot_Typ), 9751 Chars => New_External_Name (Chars (Prot_Typ), 'A')); 9752 9753 case Corresponding_Runtime_Package (Prot_Typ) is 9754 when System_Tasking_Protected_Objects_Entries => 9755 Expr := Entries_Aggr; 9756 Obj_Def := 9757 Make_Subtype_Indication (Loc, 9758 Subtype_Mark => 9759 New_Occurrence_Of 9760 (RTE (RE_Protected_Entry_Body_Array), Loc), 9761 Constraint => 9762 Make_Index_Or_Discriminant_Constraint (Loc, 9763 Constraints => New_List ( 9764 Make_Range (Loc, 9765 Make_Integer_Literal (Loc, 1), 9766 Make_Integer_Literal (Loc, E_Count))))); 9767 9768 when System_Tasking_Protected_Objects_Single_Entry => 9769 Expr := Remove_Head (Expressions (Entries_Aggr)); 9770 Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc); 9771 9772 when others => 9773 raise Program_Error; 9774 end case; 9775 9776 Body_Arr := 9777 Make_Object_Declaration (Loc, 9778 Defining_Identifier => Body_Id, 9779 Aliased_Present => True, 9780 Constant_Present => True, 9781 Object_Definition => Obj_Def, 9782 Expression => Expr); 9783 9784 -- A pointer to this array will be placed in the corresponding record 9785 -- by its initialization procedure so this needs to be analyzed here. 9786 9787 Insert_After (Current_Node, Body_Arr); 9788 Current_Node := Body_Arr; 9789 Analyze (Body_Arr); 9790 9791 Set_Entry_Bodies_Array (Prot_Typ, Body_Id); 9792 9793 -- Finally, build the function that maps an entry index into the 9794 -- corresponding body. A pointer to this function is placed in each 9795 -- object of the type. Except for a ravenscar-like profile (no abort, 9796 -- no entry queue, 1 entry) 9797 9798 if Corresponding_Runtime_Package (Prot_Typ) = 9799 System_Tasking_Protected_Objects_Entries 9800 then 9801 Sub := 9802 Make_Subprogram_Declaration (Loc, 9803 Specification => Build_Find_Body_Index_Spec (Prot_Typ)); 9804 9805 Insert_After (Current_Node, Sub); 9806 Analyze (Sub); 9807 end if; 9808 end if; 9809 end Expand_N_Protected_Type_Declaration; 9810 9811 -------------------------------- 9812 -- Expand_N_Requeue_Statement -- 9813 -------------------------------- 9814 9815 -- A nondispatching requeue statement is expanded into one of four GNARLI 9816 -- operations, depending on the source and destination (task or protected 9817 -- object). A dispatching requeue statement is expanded into a call to the 9818 -- predefined primitive _Disp_Requeue. In addition, code is generated to 9819 -- jump around the remainder of processing for the original entry and, if 9820 -- the destination is (different) protected object, to attempt to service 9821 -- it. The following illustrates the various cases: 9822 9823 -- procedure entE 9824 -- (O : System.Address; 9825 -- P : System.Address; 9826 -- E : Protected_Entry_Index) 9827 -- is 9828 -- <discriminant renamings> 9829 -- <private object renamings> 9830 -- type poVP is access poV; 9831 -- _object : ptVP := ptVP!(O); 9832 9833 -- begin 9834 -- begin 9835 -- <start of statement sequence for entry> 9836 9837 -- -- Requeue from one protected entry body to another protected 9838 -- -- entry. 9839 9840 -- Requeue_Protected_Entry ( 9841 -- _object._object'Access, 9842 -- new._object'Access, 9843 -- E, 9844 -- Abort_Present); 9845 -- return; 9846 9847 -- <some more of the statement sequence for entry> 9848 9849 -- -- Requeue from an entry body to a task entry 9850 9851 -- Requeue_Protected_To_Task_Entry ( 9852 -- New._task_id, 9853 -- E, 9854 -- Abort_Present); 9855 -- return; 9856 9857 -- <rest of statement sequence for entry> 9858 -- Complete_Entry_Body (_object._object); 9859 9860 -- exception 9861 -- when all others => 9862 -- Exceptional_Complete_Entry_Body ( 9863 -- _object._object, Get_GNAT_Exception); 9864 -- end; 9865 -- end entE; 9866 9867 -- Requeue of a task entry call to a task entry 9868 9869 -- Accept_Call (E, Ann); 9870 -- <start of statement sequence for accept statement> 9871 -- Requeue_Task_Entry (New._task_id, E, Abort_Present); 9872 -- goto Lnn; 9873 -- <rest of statement sequence for accept statement> 9874 -- <<Lnn>> 9875 -- Complete_Rendezvous; 9876 9877 -- exception 9878 -- when all others => 9879 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9880 9881 -- Requeue of a task entry call to a protected entry 9882 9883 -- Accept_Call (E, Ann); 9884 -- <start of statement sequence for accept statement> 9885 -- Requeue_Task_To_Protected_Entry ( 9886 -- new._object'Access, 9887 -- E, 9888 -- Abort_Present); 9889 -- newS (new, Pnn); 9890 -- goto Lnn; 9891 -- <rest of statement sequence for accept statement> 9892 -- <<Lnn>> 9893 -- Complete_Rendezvous; 9894 9895 -- exception 9896 -- when all others => 9897 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9898 9899 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9900 -- marked by pragma Implemented (XXX, By_Entry). 9901 9902 -- The requeue is inside a protected entry: 9903 9904 -- procedure entE 9905 -- (O : System.Address; 9906 -- P : System.Address; 9907 -- E : Protected_Entry_Index) 9908 -- is 9909 -- <discriminant renamings> 9910 -- <private object renamings> 9911 -- type poVP is access poV; 9912 -- _object : ptVP := ptVP!(O); 9913 9914 -- begin 9915 -- begin 9916 -- <start of statement sequence for entry> 9917 9918 -- _Disp_Requeue 9919 -- (<interface class-wide object>, 9920 -- True, 9921 -- _object'Address, 9922 -- Ada.Tags.Get_Offset_Index 9923 -- (Tag (_object), 9924 -- <interface dispatch table index of target entry>), 9925 -- Abort_Present); 9926 -- return; 9927 9928 -- <rest of statement sequence for entry> 9929 -- Complete_Entry_Body (_object._object); 9930 9931 -- exception 9932 -- when all others => 9933 -- Exceptional_Complete_Entry_Body ( 9934 -- _object._object, Get_GNAT_Exception); 9935 -- end; 9936 -- end entE; 9937 9938 -- The requeue is inside a task entry: 9939 9940 -- Accept_Call (E, Ann); 9941 -- <start of statement sequence for accept statement> 9942 -- _Disp_Requeue 9943 -- (<interface class-wide object>, 9944 -- False, 9945 -- null, 9946 -- Ada.Tags.Get_Offset_Index 9947 -- (Tag (_object), 9948 -- <interface dispatch table index of target entrt>), 9949 -- Abort_Present); 9950 -- newS (new, Pnn); 9951 -- goto Lnn; 9952 -- <rest of statement sequence for accept statement> 9953 -- <<Lnn>> 9954 -- Complete_Rendezvous; 9955 9956 -- exception 9957 -- when all others => 9958 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9959 9960 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9961 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue 9962 -- statement is replaced by a dispatching call with actual parameters taken 9963 -- from the inner-most accept statement or entry body. 9964 9965 -- Target.Primitive (Param1, ..., ParamN); 9966 9967 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9968 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked 9969 -- at all. 9970 9971 -- declare 9972 -- S : constant Offset_Index := 9973 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename)); 9974 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S); 9975 9976 -- begin 9977 -- if C = POK_Protected_Entry 9978 -- or else C = POK_Task_Entry 9979 -- then 9980 -- <statements for dispatching requeue> 9981 9982 -- elsif C = POK_Protected_Procedure then 9983 -- <dispatching call equivalent> 9984 9985 -- else 9986 -- raise Program_Error; 9987 -- end if; 9988 -- end; 9989 9990 procedure Expand_N_Requeue_Statement (N : Node_Id) is 9991 Loc : constant Source_Ptr := Sloc (N); 9992 Conc_Typ : Entity_Id; 9993 Concval : Node_Id; 9994 Ename : Node_Id; 9995 Index : Node_Id; 9996 Old_Typ : Entity_Id; 9997 9998 function Build_Dispatching_Call_Equivalent return Node_Id; 9999 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 10000 -- the form Concval.Ename. It is statically known that Ename is allowed 10001 -- to be implemented by a protected procedure. Create a dispatching call 10002 -- equivalent of Concval.Ename taking the actual parameters from the 10003 -- inner-most accept statement or entry body. 10004 10005 function Build_Dispatching_Requeue return Node_Id; 10006 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 10007 -- the form Concval.Ename. It is statically known that Ename is allowed 10008 -- to be implemented by a protected or a task entry. Create a call to 10009 -- primitive _Disp_Requeue which handles the low-level actions. 10010 10011 function Build_Dispatching_Requeue_To_Any return Node_Id; 10012 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 10013 -- the form Concval.Ename. Ename is either marked by pragma Implemented 10014 -- (XXX, By_Any | Optional) or not marked at all. Create a block which 10015 -- determines at runtime whether Ename denotes an entry or a procedure 10016 -- and perform the appropriate kind of dispatching select. 10017 10018 function Build_Normal_Requeue return Node_Id; 10019 -- N denotes a nondispatching requeue statement to either a task or a 10020 -- protected entry. Build the appropriate runtime call to perform the 10021 -- action. 10022 10023 function Build_Skip_Statement (Search : Node_Id) return Node_Id; 10024 -- For a protected entry, create a return statement to skip the rest of 10025 -- the entry body. Otherwise, create a goto statement to skip the rest 10026 -- of a task accept statement. The lookup for the enclosing entry body 10027 -- or accept statement starts from Search. 10028 10029 --------------------------------------- 10030 -- Build_Dispatching_Call_Equivalent -- 10031 --------------------------------------- 10032 10033 function Build_Dispatching_Call_Equivalent return Node_Id is 10034 Call_Ent : constant Entity_Id := Entity (Ename); 10035 Obj : constant Node_Id := Original_Node (Concval); 10036 Acc_Ent : Node_Id; 10037 Actuals : List_Id; 10038 Formal : Node_Id; 10039 Formals : List_Id; 10040 10041 begin 10042 -- Climb the parent chain looking for the inner-most entry body or 10043 -- accept statement. 10044 10045 Acc_Ent := N; 10046 while Present (Acc_Ent) 10047 and then not Nkind_In (Acc_Ent, N_Accept_Statement, 10048 N_Entry_Body) 10049 loop 10050 Acc_Ent := Parent (Acc_Ent); 10051 end loop; 10052 10053 -- A requeue statement should be housed inside an entry body or an 10054 -- accept statement at some level. If this is not the case, then the 10055 -- tree is malformed. 10056 10057 pragma Assert (Present (Acc_Ent)); 10058 10059 -- Recover the list of formal parameters 10060 10061 if Nkind (Acc_Ent) = N_Entry_Body then 10062 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent); 10063 end if; 10064 10065 Formals := Parameter_Specifications (Acc_Ent); 10066 10067 -- Create the actual parameters for the dispatching call. These are 10068 -- simply copies of the entry body or accept statement formals in the 10069 -- same order as they appear. 10070 10071 Actuals := No_List; 10072 10073 if Present (Formals) then 10074 Actuals := New_List; 10075 Formal := First (Formals); 10076 while Present (Formal) loop 10077 Append_To (Actuals, 10078 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 10079 Next (Formal); 10080 end loop; 10081 end if; 10082 10083 -- Generate: 10084 -- Obj.Call_Ent (Actuals); 10085 10086 return 10087 Make_Procedure_Call_Statement (Loc, 10088 Name => 10089 Make_Selected_Component (Loc, 10090 Prefix => Make_Identifier (Loc, Chars (Obj)), 10091 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))), 10092 10093 Parameter_Associations => Actuals); 10094 end Build_Dispatching_Call_Equivalent; 10095 10096 ------------------------------- 10097 -- Build_Dispatching_Requeue -- 10098 ------------------------------- 10099 10100 function Build_Dispatching_Requeue return Node_Id is 10101 Params : constant List_Id := New_List; 10102 10103 begin 10104 -- Process the "with abort" parameter 10105 10106 Prepend_To (Params, 10107 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10108 10109 -- Process the entry wrapper's position in the primary dispatch 10110 -- table parameter. Generate: 10111 10112 -- Ada.Tags.Get_Entry_Index 10113 -- (T => To_Tag_Ptr (Obj'Address).all, 10114 -- Position => 10115 -- Ada.Tags.Get_Offset_Index 10116 -- (Ada.Tags.Tag (Concval), 10117 -- <interface dispatch table position of Ename>)); 10118 10119 -- Note that Obj'Address is recursively expanded into a call to 10120 -- Base_Address (Obj). 10121 10122 if Tagged_Type_Expansion then 10123 Prepend_To (Params, 10124 Make_Function_Call (Loc, 10125 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 10126 Parameter_Associations => New_List ( 10127 10128 Make_Explicit_Dereference (Loc, 10129 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 10130 Make_Attribute_Reference (Loc, 10131 Prefix => New_Copy_Tree (Concval), 10132 Attribute_Name => Name_Address))), 10133 10134 Make_Function_Call (Loc, 10135 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 10136 Parameter_Associations => New_List ( 10137 Unchecked_Convert_To (RTE (RE_Tag), Concval), 10138 Make_Integer_Literal (Loc, 10139 DT_Position (Entity (Ename)))))))); 10140 10141 -- VM targets 10142 10143 else 10144 Prepend_To (Params, 10145 Make_Function_Call (Loc, 10146 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 10147 Parameter_Associations => New_List ( 10148 10149 Make_Attribute_Reference (Loc, 10150 Prefix => Concval, 10151 Attribute_Name => Name_Tag), 10152 10153 Make_Function_Call (Loc, 10154 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 10155 10156 Parameter_Associations => New_List ( 10157 10158 -- Obj_Tag 10159 10160 Make_Attribute_Reference (Loc, 10161 Prefix => Concval, 10162 Attribute_Name => Name_Tag), 10163 10164 -- Tag_Typ 10165 10166 Make_Attribute_Reference (Loc, 10167 Prefix => New_Occurrence_Of (Etype (Concval), Loc), 10168 Attribute_Name => Name_Tag), 10169 10170 -- Position 10171 10172 Make_Integer_Literal (Loc, 10173 DT_Position (Entity (Ename)))))))); 10174 end if; 10175 10176 -- Specific actuals for protected to XXX requeue 10177 10178 if Is_Protected_Type (Old_Typ) then 10179 Prepend_To (Params, 10180 Make_Attribute_Reference (Loc, -- _object'Address 10181 Prefix => 10182 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10183 Attribute_Name => Name_Address)); 10184 10185 Prepend_To (Params, -- True 10186 New_Occurrence_Of (Standard_True, Loc)); 10187 10188 -- Specific actuals for task to XXX requeue 10189 10190 else 10191 pragma Assert (Is_Task_Type (Old_Typ)); 10192 10193 Prepend_To (Params, -- null 10194 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 10195 10196 Prepend_To (Params, -- False 10197 New_Occurrence_Of (Standard_False, Loc)); 10198 end if; 10199 10200 -- Add the object parameter 10201 10202 Prepend_To (Params, New_Copy_Tree (Concval)); 10203 10204 -- Generate: 10205 -- _Disp_Requeue (<Params>); 10206 10207 -- Find entity for Disp_Requeue operation, which belongs to 10208 -- the type and may not be directly visible. 10209 10210 declare 10211 Elmt : Elmt_Id; 10212 Op : Entity_Id; 10213 pragma Warnings (Off, Op); 10214 10215 begin 10216 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ))); 10217 while Present (Elmt) loop 10218 Op := Node (Elmt); 10219 exit when Chars (Op) = Name_uDisp_Requeue; 10220 Next_Elmt (Elmt); 10221 end loop; 10222 10223 return 10224 Make_Procedure_Call_Statement (Loc, 10225 Name => New_Occurrence_Of (Op, Loc), 10226 Parameter_Associations => Params); 10227 end; 10228 end Build_Dispatching_Requeue; 10229 10230 -------------------------------------- 10231 -- Build_Dispatching_Requeue_To_Any -- 10232 -------------------------------------- 10233 10234 function Build_Dispatching_Requeue_To_Any return Node_Id is 10235 Call_Ent : constant Entity_Id := Entity (Ename); 10236 Obj : constant Node_Id := Original_Node (Concval); 10237 Skip : constant Node_Id := Build_Skip_Statement (N); 10238 C : Entity_Id; 10239 Decls : List_Id; 10240 S : Entity_Id; 10241 Stmts : List_Id; 10242 10243 begin 10244 Decls := New_List; 10245 Stmts := New_List; 10246 10247 -- Dispatch table slot processing, generate: 10248 -- S : Integer; 10249 10250 S := Build_S (Loc, Decls); 10251 10252 -- Call kind processing, generate: 10253 -- C : Ada.Tags.Prim_Op_Kind; 10254 10255 C := Build_C (Loc, Decls); 10256 10257 -- Generate: 10258 -- S := Ada.Tags.Get_Offset_Index 10259 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent)); 10260 10261 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent)); 10262 10263 -- Generate: 10264 -- _Disp_Get_Prim_Op_Kind (Obj, S, C); 10265 10266 Append_To (Stmts, 10267 Make_Procedure_Call_Statement (Loc, 10268 Name => 10269 New_Occurrence_Of ( 10270 Find_Prim_Op (Etype (Etype (Obj)), 10271 Name_uDisp_Get_Prim_Op_Kind), 10272 Loc), 10273 Parameter_Associations => New_List ( 10274 New_Copy_Tree (Obj), 10275 New_Occurrence_Of (S, Loc), 10276 New_Occurrence_Of (C, Loc)))); 10277 10278 Append_To (Stmts, 10279 10280 -- if C = POK_Protected_Entry 10281 -- or else C = POK_Task_Entry 10282 -- then 10283 10284 Make_Implicit_If_Statement (N, 10285 Condition => 10286 Make_Op_Or (Loc, 10287 Left_Opnd => 10288 Make_Op_Eq (Loc, 10289 Left_Opnd => 10290 New_Occurrence_Of (C, Loc), 10291 Right_Opnd => 10292 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 10293 10294 Right_Opnd => 10295 Make_Op_Eq (Loc, 10296 Left_Opnd => 10297 New_Occurrence_Of (C, Loc), 10298 Right_Opnd => 10299 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 10300 10301 -- Dispatching requeue equivalent 10302 10303 Then_Statements => New_List ( 10304 Build_Dispatching_Requeue, 10305 Skip), 10306 10307 -- elsif C = POK_Protected_Procedure then 10308 10309 Elsif_Parts => New_List ( 10310 Make_Elsif_Part (Loc, 10311 Condition => 10312 Make_Op_Eq (Loc, 10313 Left_Opnd => 10314 New_Occurrence_Of (C, Loc), 10315 Right_Opnd => 10316 New_Occurrence_Of ( 10317 RTE (RE_POK_Protected_Procedure), Loc)), 10318 10319 -- Dispatching call equivalent 10320 10321 Then_Statements => New_List ( 10322 Build_Dispatching_Call_Equivalent))), 10323 10324 -- else 10325 -- raise Program_Error; 10326 -- end if; 10327 10328 Else_Statements => New_List ( 10329 Make_Raise_Program_Error (Loc, 10330 Reason => PE_Explicit_Raise)))); 10331 10332 -- Wrap everything into a block 10333 10334 return 10335 Make_Block_Statement (Loc, 10336 Declarations => Decls, 10337 Handled_Statement_Sequence => 10338 Make_Handled_Sequence_Of_Statements (Loc, 10339 Statements => Stmts)); 10340 end Build_Dispatching_Requeue_To_Any; 10341 10342 -------------------------- 10343 -- Build_Normal_Requeue -- 10344 -------------------------- 10345 10346 function Build_Normal_Requeue return Node_Id is 10347 Params : constant List_Id := New_List; 10348 Param : Node_Id; 10349 RT_Call : Node_Id; 10350 10351 begin 10352 -- Process the "with abort" parameter 10353 10354 Prepend_To (Params, 10355 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10356 10357 -- Add the index expression to the parameters. It is common among all 10358 -- four cases. 10359 10360 Prepend_To (Params, 10361 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ)); 10362 10363 if Is_Protected_Type (Old_Typ) then 10364 declare 10365 Self_Param : Node_Id; 10366 10367 begin 10368 Self_Param := 10369 Make_Attribute_Reference (Loc, 10370 Prefix => 10371 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10372 Attribute_Name => 10373 Name_Unchecked_Access); 10374 10375 -- Protected to protected requeue 10376 10377 if Is_Protected_Type (Conc_Typ) then 10378 RT_Call := 10379 New_Occurrence_Of ( 10380 RTE (RE_Requeue_Protected_Entry), Loc); 10381 10382 Param := 10383 Make_Attribute_Reference (Loc, 10384 Prefix => 10385 Concurrent_Ref (Concval), 10386 Attribute_Name => 10387 Name_Unchecked_Access); 10388 10389 -- Protected to task requeue 10390 10391 else pragma Assert (Is_Task_Type (Conc_Typ)); 10392 RT_Call := 10393 New_Occurrence_Of ( 10394 RTE (RE_Requeue_Protected_To_Task_Entry), Loc); 10395 10396 Param := Concurrent_Ref (Concval); 10397 end if; 10398 10399 Prepend_To (Params, Param); 10400 Prepend_To (Params, Self_Param); 10401 end; 10402 10403 else pragma Assert (Is_Task_Type (Old_Typ)); 10404 10405 -- Task to protected requeue 10406 10407 if Is_Protected_Type (Conc_Typ) then 10408 RT_Call := 10409 New_Occurrence_Of ( 10410 RTE (RE_Requeue_Task_To_Protected_Entry), Loc); 10411 10412 Param := 10413 Make_Attribute_Reference (Loc, 10414 Prefix => 10415 Concurrent_Ref (Concval), 10416 Attribute_Name => 10417 Name_Unchecked_Access); 10418 10419 -- Task to task requeue 10420 10421 else pragma Assert (Is_Task_Type (Conc_Typ)); 10422 RT_Call := 10423 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc); 10424 10425 Param := Concurrent_Ref (Concval); 10426 end if; 10427 10428 Prepend_To (Params, Param); 10429 end if; 10430 10431 return 10432 Make_Procedure_Call_Statement (Loc, 10433 Name => RT_Call, 10434 Parameter_Associations => Params); 10435 end Build_Normal_Requeue; 10436 10437 -------------------------- 10438 -- Build_Skip_Statement -- 10439 -------------------------- 10440 10441 function Build_Skip_Statement (Search : Node_Id) return Node_Id is 10442 Skip_Stmt : Node_Id; 10443 10444 begin 10445 -- Build a return statement to skip the rest of the entire body 10446 10447 if Is_Protected_Type (Old_Typ) then 10448 Skip_Stmt := Make_Simple_Return_Statement (Loc); 10449 10450 -- If the requeue is within a task, find the end label of the 10451 -- enclosing accept statement and create a goto statement to it. 10452 10453 else 10454 declare 10455 Acc : Node_Id; 10456 Label : Node_Id; 10457 10458 begin 10459 -- Climb the parent chain looking for the enclosing accept 10460 -- statement. 10461 10462 Acc := Parent (Search); 10463 while Present (Acc) 10464 and then Nkind (Acc) /= N_Accept_Statement 10465 loop 10466 Acc := Parent (Acc); 10467 end loop; 10468 10469 -- The last statement is the second label used for completing 10470 -- the rendezvous the usual way. The label we are looking for 10471 -- is right before it. 10472 10473 Label := 10474 Prev (Last (Statements (Handled_Statement_Sequence (Acc)))); 10475 10476 pragma Assert (Nkind (Label) = N_Label); 10477 10478 -- Generate a goto statement to skip the rest of the accept 10479 10480 Skip_Stmt := 10481 Make_Goto_Statement (Loc, 10482 Name => 10483 New_Occurrence_Of (Entity (Identifier (Label)), Loc)); 10484 end; 10485 end if; 10486 10487 Set_Analyzed (Skip_Stmt); 10488 10489 return Skip_Stmt; 10490 end Build_Skip_Statement; 10491 10492 -- Start of processing for Expand_N_Requeue_Statement 10493 10494 begin 10495 -- Extract the components of the entry call 10496 10497 Extract_Entry (N, Concval, Ename, Index); 10498 Conc_Typ := Etype (Concval); 10499 10500 -- If the prefix is an access to class-wide type, dereference to get 10501 -- object and entry type. 10502 10503 if Is_Access_Type (Conc_Typ) then 10504 Conc_Typ := Designated_Type (Conc_Typ); 10505 Rewrite (Concval, 10506 Make_Explicit_Dereference (Loc, Relocate_Node (Concval))); 10507 Analyze_And_Resolve (Concval, Conc_Typ); 10508 end if; 10509 10510 -- Examine the scope stack in order to find nearest enclosing protected 10511 -- or task type. This will constitute our invocation source. 10512 10513 Old_Typ := Current_Scope; 10514 while Present (Old_Typ) 10515 and then not Is_Protected_Type (Old_Typ) 10516 and then not Is_Task_Type (Old_Typ) 10517 loop 10518 Old_Typ := Scope (Old_Typ); 10519 end loop; 10520 10521 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form 10522 -- Concval.Ename where the type of Concval is class-wide concurrent 10523 -- interface. 10524 10525 if Ada_Version >= Ada_2012 10526 and then Present (Concval) 10527 and then Is_Class_Wide_Type (Conc_Typ) 10528 and then Is_Concurrent_Interface (Conc_Typ) 10529 then 10530 declare 10531 Has_Impl : Boolean := False; 10532 Impl_Kind : Name_Id := No_Name; 10533 10534 begin 10535 -- Check whether the Ename is flagged by pragma Implemented 10536 10537 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then 10538 Has_Impl := True; 10539 Impl_Kind := Implementation_Kind (Entity (Ename)); 10540 end if; 10541 10542 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10543 -- an entry. Create a call to predefined primitive _Disp_Requeue. 10544 10545 if Has_Impl and then Impl_Kind = Name_By_Entry then 10546 Rewrite (N, Build_Dispatching_Requeue); 10547 Analyze (N); 10548 Insert_After (N, Build_Skip_Statement (N)); 10549 10550 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10551 -- a protected procedure. In this case the requeue is transformed 10552 -- into a dispatching call. 10553 10554 elsif Has_Impl 10555 and then Impl_Kind = Name_By_Protected_Procedure 10556 then 10557 Rewrite (N, Build_Dispatching_Call_Equivalent); 10558 Analyze (N); 10559 10560 -- The procedure_or_entry_NAME's implementation kind is either 10561 -- By_Any, Optional, or pragma Implemented was not applied at all. 10562 -- In this case a runtime test determines whether Ename denotes an 10563 -- entry or a protected procedure and performs the appropriate 10564 -- call. 10565 10566 else 10567 Rewrite (N, Build_Dispatching_Requeue_To_Any); 10568 Analyze (N); 10569 end if; 10570 end; 10571 10572 -- Processing for regular (nondispatching) requeues 10573 10574 else 10575 Rewrite (N, Build_Normal_Requeue); 10576 Analyze (N); 10577 Insert_After (N, Build_Skip_Statement (N)); 10578 end if; 10579 end Expand_N_Requeue_Statement; 10580 10581 ------------------------------- 10582 -- Expand_N_Selective_Accept -- 10583 ------------------------------- 10584 10585 procedure Expand_N_Selective_Accept (N : Node_Id) is 10586 Loc : constant Source_Ptr := Sloc (N); 10587 Alts : constant List_Id := Select_Alternatives (N); 10588 10589 -- Note: in the below declarations a lot of new lists are allocated 10590 -- unconditionally which may well not end up being used. That's not 10591 -- a good idea since it wastes space gratuitously ??? 10592 10593 Accept_Case : List_Id; 10594 Accept_List : constant List_Id := New_List; 10595 10596 Alt : Node_Id; 10597 Alt_List : constant List_Id := New_List; 10598 Alt_Stats : List_Id; 10599 Ann : Entity_Id := Empty; 10600 10601 Check_Guard : Boolean := True; 10602 10603 Decls : constant List_Id := New_List; 10604 Stats : constant List_Id := New_List; 10605 Body_List : constant List_Id := New_List; 10606 Trailing_List : constant List_Id := New_List; 10607 10608 Choices : List_Id; 10609 Else_Present : Boolean := False; 10610 Terminate_Alt : Node_Id := Empty; 10611 Select_Mode : Node_Id; 10612 10613 Delay_Case : List_Id; 10614 Delay_Count : Integer := 0; 10615 Delay_Val : Entity_Id; 10616 Delay_Index : Entity_Id; 10617 Delay_Min : Entity_Id; 10618 Delay_Num : Pos := 1; 10619 Delay_Alt_List : List_Id := New_List; 10620 Delay_List : constant List_Id := New_List; 10621 D : Entity_Id; 10622 M : Entity_Id; 10623 10624 First_Delay : Boolean := True; 10625 Guard_Open : Entity_Id; 10626 10627 End_Lab : Node_Id; 10628 Index : Pos := 1; 10629 Lab : Node_Id; 10630 Num_Alts : Nat; 10631 Num_Accept : Nat := 0; 10632 Proc : Node_Id; 10633 Time_Type : Entity_Id; 10634 Select_Call : Node_Id; 10635 10636 Qnam : constant Entity_Id := 10637 Make_Defining_Identifier (Loc, New_External_Name ('S', 0)); 10638 10639 Xnam : constant Entity_Id := 10640 Make_Defining_Identifier (Loc, New_External_Name ('J', 1)); 10641 10642 ----------------------- 10643 -- Local subprograms -- 10644 ----------------------- 10645 10646 function Accept_Or_Raise return List_Id; 10647 -- For the rare case where delay alternatives all have guards, and 10648 -- all of them are closed, it is still possible that there were open 10649 -- accept alternatives with no callers. We must reexamine the 10650 -- Accept_List, and execute a selective wait with no else if some 10651 -- accept is open. If none, we raise program_error. 10652 10653 procedure Add_Accept (Alt : Node_Id); 10654 -- Process a single accept statement in a select alternative. Build 10655 -- procedure for body of accept, and add entry to dispatch table with 10656 -- expression for guard, in preparation for call to run time select. 10657 10658 function Make_And_Declare_Label (Num : Int) return Node_Id; 10659 -- Manufacture a label using Num as a serial number and declare it. 10660 -- The declaration is appended to Decls. The label marks the trailing 10661 -- statements of an accept or delay alternative. 10662 10663 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; 10664 -- Build call to Selective_Wait runtime routine 10665 10666 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); 10667 -- Add code to compare value of delay with previous values, and 10668 -- generate case entry for trailing statements. 10669 10670 procedure Process_Accept_Alternative 10671 (Alt : Node_Id; 10672 Index : Int; 10673 Proc : Node_Id); 10674 -- Add code to call corresponding procedure, and branch to 10675 -- trailing statements, if any. 10676 10677 --------------------- 10678 -- Accept_Or_Raise -- 10679 --------------------- 10680 10681 function Accept_Or_Raise return List_Id is 10682 Cond : Node_Id; 10683 Stats : List_Id; 10684 J : constant Entity_Id := Make_Temporary (Loc, 'J'); 10685 10686 begin 10687 -- We generate the following: 10688 10689 -- for J in q'range loop 10690 -- if q(J).S /=null_task_entry then 10691 -- selective_wait (simple_mode,...); 10692 -- done := True; 10693 -- exit; 10694 -- end if; 10695 -- end loop; 10696 -- 10697 -- if no rendez_vous then 10698 -- raise program_error; 10699 -- end if; 10700 10701 -- Note that the code needs to know that the selector name 10702 -- in an Accept_Alternative is named S. 10703 10704 Cond := Make_Op_Ne (Loc, 10705 Left_Opnd => 10706 Make_Selected_Component (Loc, 10707 Prefix => 10708 Make_Indexed_Component (Loc, 10709 Prefix => New_Occurrence_Of (Qnam, Loc), 10710 Expressions => New_List (New_Occurrence_Of (J, Loc))), 10711 Selector_Name => Make_Identifier (Loc, Name_S)), 10712 Right_Opnd => 10713 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc)); 10714 10715 Stats := New_List ( 10716 Make_Implicit_Loop_Statement (N, 10717 Iteration_Scheme => 10718 Make_Iteration_Scheme (Loc, 10719 Loop_Parameter_Specification => 10720 Make_Loop_Parameter_Specification (Loc, 10721 Defining_Identifier => J, 10722 Discrete_Subtype_Definition => 10723 Make_Attribute_Reference (Loc, 10724 Prefix => New_Occurrence_Of (Qnam, Loc), 10725 Attribute_Name => Name_Range, 10726 Expressions => New_List ( 10727 Make_Integer_Literal (Loc, 1))))), 10728 10729 Statements => New_List ( 10730 Make_Implicit_If_Statement (N, 10731 Condition => Cond, 10732 Then_Statements => New_List ( 10733 Make_Select_Call ( 10734 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)), 10735 Make_Exit_Statement (Loc)))))); 10736 10737 Append_To (Stats, 10738 Make_Raise_Program_Error (Loc, 10739 Condition => Make_Op_Eq (Loc, 10740 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 10741 Right_Opnd => 10742 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 10743 Reason => PE_All_Guards_Closed)); 10744 10745 return Stats; 10746 end Accept_Or_Raise; 10747 10748 ---------------- 10749 -- Add_Accept -- 10750 ---------------- 10751 10752 procedure Add_Accept (Alt : Node_Id) is 10753 Acc_Stm : constant Node_Id := Accept_Statement (Alt); 10754 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm); 10755 Eloc : constant Source_Ptr := Sloc (Ename); 10756 Eent : constant Entity_Id := Entity (Ename); 10757 Index : constant Node_Id := Entry_Index (Acc_Stm); 10758 10759 Call : Node_Id; 10760 Expr : Node_Id; 10761 Null_Body : Node_Id; 10762 PB_Ent : Entity_Id; 10763 Proc_Body : Node_Id; 10764 10765 -- Start of processing for Add_Accept 10766 10767 begin 10768 if No (Ann) then 10769 Ann := Node (Last_Elmt (Accept_Address (Eent))); 10770 end if; 10771 10772 if Present (Condition (Alt)) then 10773 Expr := 10774 Make_If_Expression (Eloc, New_List ( 10775 Condition (Alt), 10776 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)), 10777 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc))); 10778 else 10779 Expr := Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)); 10780 end if; 10781 10782 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then 10783 Null_Body := New_Occurrence_Of (Standard_False, Eloc); 10784 10785 -- Always add call to Abort_Undefer when generating code, since 10786 -- this is what the runtime expects (abort deferred in 10787 -- Selective_Wait). In CodePeer mode this only confuses the 10788 -- analysis with unknown calls, so don't do it. 10789 10790 if not CodePeer_Mode then 10791 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 10792 Insert_Before 10793 (First (Statements (Handled_Statement_Sequence 10794 (Accept_Statement (Alt)))), 10795 Call); 10796 Analyze (Call); 10797 end if; 10798 10799 PB_Ent := 10800 Make_Defining_Identifier (Eloc, 10801 New_External_Name (Chars (Ename), 'A', Num_Accept)); 10802 10803 -- Link the acceptor to the original receiving entry 10804 10805 Set_Ekind (PB_Ent, E_Procedure); 10806 Set_Receiving_Entry (PB_Ent, Eent); 10807 10808 if Comes_From_Source (Alt) then 10809 Set_Debug_Info_Needed (PB_Ent); 10810 end if; 10811 10812 Proc_Body := 10813 Make_Subprogram_Body (Eloc, 10814 Specification => 10815 Make_Procedure_Specification (Eloc, 10816 Defining_Unit_Name => PB_Ent), 10817 Declarations => Declarations (Acc_Stm), 10818 Handled_Statement_Sequence => 10819 Build_Accept_Body (Accept_Statement (Alt))); 10820 10821 Reset_Scopes_To (Proc_Body, PB_Ent); 10822 10823 -- During the analysis of the body of the accept statement, any 10824 -- zero cost exception handler records were collected in the 10825 -- Accept_Handler_Records field of the N_Accept_Alternative node. 10826 -- This is where we move them to where they belong, namely the 10827 -- newly created procedure. 10828 10829 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); 10830 Append (Proc_Body, Body_List); 10831 10832 else 10833 Null_Body := New_Occurrence_Of (Standard_True, Eloc); 10834 10835 -- if accept statement has declarations, insert above, given that 10836 -- we are not creating a body for the accept. 10837 10838 if Present (Declarations (Acc_Stm)) then 10839 Insert_Actions (N, Declarations (Acc_Stm)); 10840 end if; 10841 end if; 10842 10843 Append_To (Accept_List, 10844 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr))); 10845 10846 Num_Accept := Num_Accept + 1; 10847 end Add_Accept; 10848 10849 ---------------------------- 10850 -- Make_And_Declare_Label -- 10851 ---------------------------- 10852 10853 function Make_And_Declare_Label (Num : Int) return Node_Id is 10854 Lab_Id : Node_Id; 10855 10856 begin 10857 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num)); 10858 Lab := 10859 Make_Label (Loc, Lab_Id); 10860 10861 Append_To (Decls, 10862 Make_Implicit_Label_Declaration (Loc, 10863 Defining_Identifier => 10864 Make_Defining_Identifier (Loc, Chars (Lab_Id)), 10865 Label_Construct => Lab)); 10866 10867 return Lab; 10868 end Make_And_Declare_Label; 10869 10870 ---------------------- 10871 -- Make_Select_Call -- 10872 ---------------------- 10873 10874 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is 10875 Params : constant List_Id := New_List; 10876 10877 begin 10878 Append_To (Params, 10879 Make_Attribute_Reference (Loc, 10880 Prefix => New_Occurrence_Of (Qnam, Loc), 10881 Attribute_Name => Name_Unchecked_Access)); 10882 Append_To (Params, Select_Mode); 10883 Append_To (Params, New_Occurrence_Of (Ann, Loc)); 10884 Append_To (Params, New_Occurrence_Of (Xnam, Loc)); 10885 10886 return 10887 Make_Procedure_Call_Statement (Loc, 10888 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc), 10889 Parameter_Associations => Params); 10890 end Make_Select_Call; 10891 10892 -------------------------------- 10893 -- Process_Accept_Alternative -- 10894 -------------------------------- 10895 10896 procedure Process_Accept_Alternative 10897 (Alt : Node_Id; 10898 Index : Int; 10899 Proc : Node_Id) 10900 is 10901 Astmt : constant Node_Id := Accept_Statement (Alt); 10902 Alt_Stats : List_Id; 10903 10904 begin 10905 Adjust_Condition (Condition (Alt)); 10906 10907 -- Accept with body 10908 10909 if Present (Handled_Statement_Sequence (Astmt)) then 10910 Alt_Stats := 10911 New_List ( 10912 Make_Procedure_Call_Statement (Sloc (Proc), 10913 Name => 10914 New_Occurrence_Of 10915 (Defining_Unit_Name (Specification (Proc)), 10916 Sloc (Proc)))); 10917 10918 -- Accept with no body (followed by trailing statements) 10919 10920 else 10921 Alt_Stats := Empty_List; 10922 end if; 10923 10924 Ensure_Statement_Present (Sloc (Astmt), Alt); 10925 10926 -- After the call, if any, branch to trailing statements, if any. 10927 -- We create a label for each, as well as the corresponding label 10928 -- declaration. 10929 10930 if not Is_Empty_List (Statements (Alt)) then 10931 Lab := Make_And_Declare_Label (Index); 10932 Append (Lab, Trailing_List); 10933 Append_List (Statements (Alt), Trailing_List); 10934 Append_To (Trailing_List, 10935 Make_Goto_Statement (Loc, 10936 Name => New_Copy (Identifier (End_Lab)))); 10937 10938 else 10939 Lab := End_Lab; 10940 end if; 10941 10942 Append_To (Alt_Stats, 10943 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab)))); 10944 10945 Append_To (Alt_List, 10946 Make_Case_Statement_Alternative (Loc, 10947 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)), 10948 Statements => Alt_Stats)); 10949 end Process_Accept_Alternative; 10950 10951 ------------------------------- 10952 -- Process_Delay_Alternative -- 10953 ------------------------------- 10954 10955 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is 10956 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt)); 10957 Cond : Node_Id; 10958 Delay_Alt : List_Id; 10959 10960 begin 10961 -- Deal with C/Fortran boolean as delay condition 10962 10963 Adjust_Condition (Condition (Alt)); 10964 10965 -- Determine the smallest specified delay 10966 10967 -- for each delay alternative generate: 10968 10969 -- if guard-expression then 10970 -- Delay_Val := delay-expression; 10971 -- Guard_Open := True; 10972 -- if Delay_Val < Delay_Min then 10973 -- Delay_Min := Delay_Val; 10974 -- Delay_Index := Index; 10975 -- end if; 10976 -- end if; 10977 10978 -- The enclosing if-statement is omitted if there is no guard 10979 10980 if Delay_Count = 1 or else First_Delay then 10981 First_Delay := False; 10982 10983 Delay_Alt := New_List ( 10984 Make_Assignment_Statement (Loc, 10985 Name => New_Occurrence_Of (Delay_Min, Loc), 10986 Expression => Expression (Delay_Statement (Alt)))); 10987 10988 if Delay_Count > 1 then 10989 Append_To (Delay_Alt, 10990 Make_Assignment_Statement (Loc, 10991 Name => New_Occurrence_Of (Delay_Index, Loc), 10992 Expression => Make_Integer_Literal (Loc, Index))); 10993 end if; 10994 10995 else 10996 Delay_Alt := New_List ( 10997 Make_Assignment_Statement (Loc, 10998 Name => New_Occurrence_Of (Delay_Val, Loc), 10999 Expression => Expression (Delay_Statement (Alt)))); 11000 11001 if Time_Type = Standard_Duration then 11002 Cond := 11003 Make_Op_Lt (Loc, 11004 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc), 11005 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc)); 11006 11007 else 11008 -- The scope of the time type must define a comparison 11009 -- operator. The scope itself may not be visible, so we 11010 -- construct a node with entity information to insure that 11011 -- semantic analysis can find the proper operator. 11012 11013 Cond := 11014 Make_Function_Call (Loc, 11015 Name => Make_Selected_Component (Loc, 11016 Prefix => 11017 New_Occurrence_Of (Scope (Time_Type), Loc), 11018 Selector_Name => 11019 Make_Operator_Symbol (Loc, 11020 Chars => Name_Op_Lt, 11021 Strval => No_String)), 11022 Parameter_Associations => 11023 New_List ( 11024 New_Occurrence_Of (Delay_Val, Loc), 11025 New_Occurrence_Of (Delay_Min, Loc))); 11026 11027 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type)); 11028 end if; 11029 11030 Append_To (Delay_Alt, 11031 Make_Implicit_If_Statement (N, 11032 Condition => Cond, 11033 Then_Statements => New_List ( 11034 Make_Assignment_Statement (Loc, 11035 Name => New_Occurrence_Of (Delay_Min, Loc), 11036 Expression => New_Occurrence_Of (Delay_Val, Loc)), 11037 11038 Make_Assignment_Statement (Loc, 11039 Name => New_Occurrence_Of (Delay_Index, Loc), 11040 Expression => Make_Integer_Literal (Loc, Index))))); 11041 end if; 11042 11043 if Check_Guard then 11044 Append_To (Delay_Alt, 11045 Make_Assignment_Statement (Loc, 11046 Name => New_Occurrence_Of (Guard_Open, Loc), 11047 Expression => New_Occurrence_Of (Standard_True, Loc))); 11048 end if; 11049 11050 if Present (Condition (Alt)) then 11051 Delay_Alt := New_List ( 11052 Make_Implicit_If_Statement (N, 11053 Condition => Condition (Alt), 11054 Then_Statements => Delay_Alt)); 11055 end if; 11056 11057 Append_List (Delay_Alt, Delay_List); 11058 11059 Ensure_Statement_Present (Dloc, Alt); 11060 11061 -- If the delay alternative has a statement part, add choice to the 11062 -- case statements for delays. 11063 11064 if not Is_Empty_List (Statements (Alt)) then 11065 11066 if Delay_Count = 1 then 11067 Append_List (Statements (Alt), Delay_Alt_List); 11068 11069 else 11070 Append_To (Delay_Alt_List, 11071 Make_Case_Statement_Alternative (Loc, 11072 Discrete_Choices => New_List ( 11073 Make_Integer_Literal (Loc, Index)), 11074 Statements => Statements (Alt))); 11075 end if; 11076 11077 elsif Delay_Count = 1 then 11078 11079 -- If the single delay has no trailing statements, add a branch 11080 -- to the exit label to the selective wait. 11081 11082 Delay_Alt_List := New_List ( 11083 Make_Goto_Statement (Loc, 11084 Name => New_Copy (Identifier (End_Lab)))); 11085 11086 end if; 11087 end Process_Delay_Alternative; 11088 11089 -- Start of processing for Expand_N_Selective_Accept 11090 11091 begin 11092 Process_Statements_For_Controlled_Objects (N); 11093 11094 -- First insert some declarations before the select. The first is: 11095 11096 -- Ann : Address 11097 11098 -- This variable holds the parameters passed to the accept body. This 11099 -- declaration has already been inserted by the time we get here by 11100 -- a call to Expand_Accept_Declarations made from the semantics when 11101 -- processing the first accept statement contained in the select. We 11102 -- can find this entity as Accept_Address (E), where E is any of the 11103 -- entries references by contained accept statements. 11104 11105 -- The first step is to scan the list of Selective_Accept_Statements 11106 -- to find this entity, and also count the number of accepts, and 11107 -- determine if terminated, delay or else is present: 11108 11109 Num_Alts := 0; 11110 11111 Alt := First (Alts); 11112 while Present (Alt) loop 11113 Process_Statements_For_Controlled_Objects (Alt); 11114 11115 if Nkind (Alt) = N_Accept_Alternative then 11116 Add_Accept (Alt); 11117 11118 elsif Nkind (Alt) = N_Delay_Alternative then 11119 Delay_Count := Delay_Count + 1; 11120 11121 -- If the delays are relative delays, the delay expressions have 11122 -- type Standard_Duration. Otherwise they must have some time type 11123 -- recognized by GNAT. 11124 11125 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then 11126 Time_Type := Standard_Duration; 11127 else 11128 Time_Type := Etype (Expression (Delay_Statement (Alt))); 11129 11130 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) 11131 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time) 11132 then 11133 null; 11134 else 11135 Error_Msg_NE ( 11136 "& is not a time type (RM 9.6(6))", 11137 Expression (Delay_Statement (Alt)), Time_Type); 11138 Time_Type := Standard_Duration; 11139 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type); 11140 end if; 11141 end if; 11142 11143 if No (Condition (Alt)) then 11144 11145 -- This guard will always be open 11146 11147 Check_Guard := False; 11148 end if; 11149 11150 elsif Nkind (Alt) = N_Terminate_Alternative then 11151 Adjust_Condition (Condition (Alt)); 11152 Terminate_Alt := Alt; 11153 end if; 11154 11155 Num_Alts := Num_Alts + 1; 11156 Next (Alt); 11157 end loop; 11158 11159 Else_Present := Present (Else_Statements (N)); 11160 11161 -- At the same time (see procedure Add_Accept) we build the accept list: 11162 11163 -- Qnn : Accept_List (1 .. num-select) := ( 11164 -- (null-body, entry-index), 11165 -- (null-body, entry-index), 11166 -- .. 11167 -- (null_body, entry-index)); 11168 11169 -- In the above declaration, null-body is True if the corresponding 11170 -- accept has no body, and false otherwise. The entry is either the 11171 -- entry index expression if there is no guard, or if a guard is 11172 -- present, then an if expression of the form: 11173 11174 -- (if guard then entry-index else Null_Task_Entry) 11175 11176 -- If a guard is statically known to be false, the entry can simply 11177 -- be omitted from the accept list. 11178 11179 Append_To (Decls, 11180 Make_Object_Declaration (Loc, 11181 Defining_Identifier => Qnam, 11182 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc), 11183 Aliased_Present => True, 11184 Expression => 11185 Make_Qualified_Expression (Loc, 11186 Subtype_Mark => 11187 New_Occurrence_Of (RTE (RE_Accept_List), Loc), 11188 Expression => 11189 Make_Aggregate (Loc, Expressions => Accept_List)))); 11190 11191 -- Then we declare the variable that holds the index for the accept 11192 -- that will be selected for service: 11193 11194 -- Xnn : Select_Index; 11195 11196 Append_To (Decls, 11197 Make_Object_Declaration (Loc, 11198 Defining_Identifier => Xnam, 11199 Object_Definition => 11200 New_Occurrence_Of (RTE (RE_Select_Index), Loc), 11201 Expression => 11202 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc))); 11203 11204 -- After this follow procedure declarations for each accept body 11205 11206 -- procedure Pnn is 11207 -- begin 11208 -- ... 11209 -- end; 11210 11211 -- where the ... are statements from the corresponding procedure body. 11212 -- No parameters are involved, since the parameters are passed via Ann 11213 -- and the parameter references have already been expanded to be direct 11214 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, 11215 -- any embedded tasking statements (which would normally be illegal in 11216 -- procedures), have been converted to calls to the tasking runtime so 11217 -- there is no problem in putting them into procedures. 11218 11219 -- The original accept statement has been expanded into a block in 11220 -- the same fashion as for simple accepts (see Build_Accept_Body). 11221 11222 -- Note: we don't really need to build these procedures for the case 11223 -- where no delay statement is present, but it is just as easy to 11224 -- build them unconditionally, and not significantly inefficient, 11225 -- since if they are short they will be inlined anyway. 11226 11227 -- The procedure declarations have been assembled in Body_List 11228 11229 -- If delays are present, we must compute the required delay. 11230 -- We first generate the declarations: 11231 11232 -- Delay_Index : Boolean := 0; 11233 -- Delay_Min : Some_Time_Type.Time; 11234 -- Delay_Val : Some_Time_Type.Time; 11235 11236 -- Delay_Index will be set to the index of the minimum delay, i.e. the 11237 -- active delay that is actually chosen as the basis for the possible 11238 -- delay if an immediate rendez-vous is not possible. 11239 11240 -- In the most common case there is a single delay statement, and this 11241 -- is handled specially. 11242 11243 if Delay_Count > 0 then 11244 11245 -- Generate the required declarations 11246 11247 Delay_Val := 11248 Make_Defining_Identifier (Loc, New_External_Name ('D', 1)); 11249 Delay_Index := 11250 Make_Defining_Identifier (Loc, New_External_Name ('D', 2)); 11251 Delay_Min := 11252 Make_Defining_Identifier (Loc, New_External_Name ('D', 3)); 11253 11254 Append_To (Decls, 11255 Make_Object_Declaration (Loc, 11256 Defining_Identifier => Delay_Val, 11257 Object_Definition => New_Occurrence_Of (Time_Type, Loc))); 11258 11259 Append_To (Decls, 11260 Make_Object_Declaration (Loc, 11261 Defining_Identifier => Delay_Index, 11262 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 11263 Expression => Make_Integer_Literal (Loc, 0))); 11264 11265 Append_To (Decls, 11266 Make_Object_Declaration (Loc, 11267 Defining_Identifier => Delay_Min, 11268 Object_Definition => New_Occurrence_Of (Time_Type, Loc), 11269 Expression => 11270 Unchecked_Convert_To (Time_Type, 11271 Make_Attribute_Reference (Loc, 11272 Prefix => 11273 New_Occurrence_Of (Underlying_Type (Time_Type), Loc), 11274 Attribute_Name => Name_Last)))); 11275 11276 -- Create Duration and Delay_Mode objects used for passing a delay 11277 -- value to RTS 11278 11279 D := Make_Temporary (Loc, 'D'); 11280 M := Make_Temporary (Loc, 'M'); 11281 11282 declare 11283 Discr : Entity_Id; 11284 11285 begin 11286 -- Note that these values are defined in s-osprim.ads and must 11287 -- be kept in sync: 11288 -- 11289 -- Relative : constant := 0; 11290 -- Absolute_Calendar : constant := 1; 11291 -- Absolute_RT : constant := 2; 11292 11293 if Time_Type = Standard_Duration then 11294 Discr := Make_Integer_Literal (Loc, 0); 11295 11296 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11297 Discr := Make_Integer_Literal (Loc, 1); 11298 11299 else 11300 pragma Assert 11301 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11302 Discr := Make_Integer_Literal (Loc, 2); 11303 end if; 11304 11305 Append_To (Decls, 11306 Make_Object_Declaration (Loc, 11307 Defining_Identifier => D, 11308 Object_Definition => 11309 New_Occurrence_Of (Standard_Duration, Loc))); 11310 11311 Append_To (Decls, 11312 Make_Object_Declaration (Loc, 11313 Defining_Identifier => M, 11314 Object_Definition => 11315 New_Occurrence_Of (Standard_Integer, Loc), 11316 Expression => Discr)); 11317 end; 11318 11319 if Check_Guard then 11320 Guard_Open := 11321 Make_Defining_Identifier (Loc, New_External_Name ('G', 1)); 11322 11323 Append_To (Decls, 11324 Make_Object_Declaration (Loc, 11325 Defining_Identifier => Guard_Open, 11326 Object_Definition => 11327 New_Occurrence_Of (Standard_Boolean, Loc), 11328 Expression => 11329 New_Occurrence_Of (Standard_False, Loc))); 11330 end if; 11331 11332 -- Delay_Count is zero, don't need M and D set (suppress warning) 11333 11334 else 11335 M := Empty; 11336 D := Empty; 11337 end if; 11338 11339 if Present (Terminate_Alt) then 11340 11341 -- If the terminate alternative guard is False, use 11342 -- Simple_Mode; otherwise use Terminate_Mode. 11343 11344 if Present (Condition (Terminate_Alt)) then 11345 Select_Mode := Make_If_Expression (Loc, 11346 New_List (Condition (Terminate_Alt), 11347 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc), 11348 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc))); 11349 else 11350 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc); 11351 end if; 11352 11353 elsif Else_Present or Delay_Count > 0 then 11354 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc); 11355 11356 else 11357 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc); 11358 end if; 11359 11360 Select_Call := Make_Select_Call (Select_Mode); 11361 Append (Select_Call, Stats); 11362 11363 -- Now generate code to act on the result. There is an entry 11364 -- in this case for each accept statement with a non-null body, 11365 -- followed by a branch to the statements that follow the Accept. 11366 -- In the absence of delay alternatives, we generate: 11367 11368 -- case X is 11369 -- when No_Rendezvous => -- omitted if simple mode 11370 -- goto Lab0; 11371 11372 -- when 1 => 11373 -- P1n; 11374 -- goto Lab1; 11375 11376 -- when 2 => 11377 -- P2n; 11378 -- goto Lab2; 11379 11380 -- when others => 11381 -- goto Exit; 11382 -- end case; 11383 -- 11384 -- Lab0: Else_Statements; 11385 -- goto exit; 11386 11387 -- Lab1: Trailing_Statements1; 11388 -- goto Exit; 11389 -- 11390 -- Lab2: Trailing_Statements2; 11391 -- goto Exit; 11392 -- ... 11393 -- Exit: 11394 11395 -- Generate label for common exit 11396 11397 End_Lab := Make_And_Declare_Label (Num_Alts + 1); 11398 11399 -- First entry is the default case, when no rendezvous is possible 11400 11401 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)); 11402 11403 if Else_Present then 11404 11405 -- If no rendezvous is possible, the else part is executed 11406 11407 Lab := Make_And_Declare_Label (0); 11408 Alt_Stats := New_List ( 11409 Make_Goto_Statement (Loc, 11410 Name => New_Copy (Identifier (Lab)))); 11411 11412 Append (Lab, Trailing_List); 11413 Append_List (Else_Statements (N), Trailing_List); 11414 Append_To (Trailing_List, 11415 Make_Goto_Statement (Loc, 11416 Name => New_Copy (Identifier (End_Lab)))); 11417 else 11418 Alt_Stats := New_List ( 11419 Make_Goto_Statement (Loc, 11420 Name => New_Copy (Identifier (End_Lab)))); 11421 end if; 11422 11423 Append_To (Alt_List, 11424 Make_Case_Statement_Alternative (Loc, 11425 Discrete_Choices => Choices, 11426 Statements => Alt_Stats)); 11427 11428 -- We make use of the fact that Accept_Index is an integer type, and 11429 -- generate successive literals for entries for each accept. Only those 11430 -- for which there is a body or trailing statements get a case entry. 11431 11432 Alt := First (Select_Alternatives (N)); 11433 Proc := First (Body_List); 11434 while Present (Alt) loop 11435 11436 if Nkind (Alt) = N_Accept_Alternative then 11437 Process_Accept_Alternative (Alt, Index, Proc); 11438 Index := Index + 1; 11439 11440 if Present 11441 (Handled_Statement_Sequence (Accept_Statement (Alt))) 11442 then 11443 Next (Proc); 11444 end if; 11445 11446 elsif Nkind (Alt) = N_Delay_Alternative then 11447 Process_Delay_Alternative (Alt, Delay_Num); 11448 Delay_Num := Delay_Num + 1; 11449 end if; 11450 11451 Next (Alt); 11452 end loop; 11453 11454 -- An others choice is always added to the main case, as well 11455 -- as the delay case (to satisfy the compiler). 11456 11457 Append_To (Alt_List, 11458 Make_Case_Statement_Alternative (Loc, 11459 Discrete_Choices => 11460 New_List (Make_Others_Choice (Loc)), 11461 Statements => 11462 New_List (Make_Goto_Statement (Loc, 11463 Name => New_Copy (Identifier (End_Lab)))))); 11464 11465 Accept_Case := New_List ( 11466 Make_Case_Statement (Loc, 11467 Expression => New_Occurrence_Of (Xnam, Loc), 11468 Alternatives => Alt_List)); 11469 11470 Append_List (Trailing_List, Accept_Case); 11471 Append_List (Body_List, Decls); 11472 11473 -- Construct case statement for trailing statements of delay 11474 -- alternatives, if there are several of them. 11475 11476 if Delay_Count > 1 then 11477 Append_To (Delay_Alt_List, 11478 Make_Case_Statement_Alternative (Loc, 11479 Discrete_Choices => 11480 New_List (Make_Others_Choice (Loc)), 11481 Statements => 11482 New_List (Make_Null_Statement (Loc)))); 11483 11484 Delay_Case := New_List ( 11485 Make_Case_Statement (Loc, 11486 Expression => New_Occurrence_Of (Delay_Index, Loc), 11487 Alternatives => Delay_Alt_List)); 11488 else 11489 Delay_Case := Delay_Alt_List; 11490 end if; 11491 11492 -- If there are no delay alternatives, we append the case statement 11493 -- to the statement list. 11494 11495 if Delay_Count = 0 then 11496 Append_List (Accept_Case, Stats); 11497 11498 -- Delay alternatives present 11499 11500 else 11501 -- If delay alternatives are present we generate: 11502 11503 -- find minimum delay. 11504 -- DX := minimum delay; 11505 -- M := <delay mode>; 11506 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P, 11507 -- DX, MX, X); 11508 -- 11509 -- if X = No_Rendezvous then 11510 -- case statement for delay statements. 11511 -- else 11512 -- case statement for accept alternatives. 11513 -- end if; 11514 11515 declare 11516 Cases : Node_Id; 11517 Stmt : Node_Id; 11518 Parms : List_Id; 11519 Parm : Node_Id; 11520 Conv : Node_Id; 11521 11522 begin 11523 -- The type of the delay expression is known to be legal 11524 11525 if Time_Type = Standard_Duration then 11526 Conv := New_Occurrence_Of (Delay_Min, Loc); 11527 11528 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11529 Conv := Make_Function_Call (Loc, 11530 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 11531 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11532 11533 else 11534 pragma Assert 11535 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11536 11537 Conv := Make_Function_Call (Loc, 11538 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 11539 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11540 end if; 11541 11542 Stmt := Make_Assignment_Statement (Loc, 11543 Name => New_Occurrence_Of (D, Loc), 11544 Expression => Conv); 11545 11546 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) 11547 11548 Parms := Parameter_Associations (Select_Call); 11549 11550 Parm := First (Parms); 11551 while Present (Parm) and then Parm /= Select_Mode loop 11552 Next (Parm); 11553 end loop; 11554 11555 pragma Assert (Present (Parm)); 11556 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc)); 11557 Analyze (Parm); 11558 11559 -- Prepare two new parameters of Duration and Delay_Mode type 11560 -- which represent the value and the mode of the minimum delay. 11561 11562 Next (Parm); 11563 Insert_After (Parm, New_Occurrence_Of (M, Loc)); 11564 Insert_After (Parm, New_Occurrence_Of (D, Loc)); 11565 11566 -- Create a call to RTS 11567 11568 Rewrite (Select_Call, 11569 Make_Procedure_Call_Statement (Loc, 11570 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc), 11571 Parameter_Associations => Parms)); 11572 11573 -- This new call should follow the calculation of the minimum 11574 -- delay. 11575 11576 Insert_List_Before (Select_Call, Delay_List); 11577 11578 if Check_Guard then 11579 Stmt := 11580 Make_Implicit_If_Statement (N, 11581 Condition => New_Occurrence_Of (Guard_Open, Loc), 11582 Then_Statements => New_List ( 11583 New_Copy_Tree (Stmt), 11584 New_Copy_Tree (Select_Call)), 11585 Else_Statements => Accept_Or_Raise); 11586 Rewrite (Select_Call, Stmt); 11587 else 11588 Insert_Before (Select_Call, Stmt); 11589 end if; 11590 11591 Cases := 11592 Make_Implicit_If_Statement (N, 11593 Condition => Make_Op_Eq (Loc, 11594 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 11595 Right_Opnd => 11596 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 11597 11598 Then_Statements => Delay_Case, 11599 Else_Statements => Accept_Case); 11600 11601 Append (Cases, Stats); 11602 end; 11603 end if; 11604 11605 Append (End_Lab, Stats); 11606 11607 -- Replace accept statement with appropriate block 11608 11609 Rewrite (N, 11610 Make_Block_Statement (Loc, 11611 Declarations => Decls, 11612 Handled_Statement_Sequence => 11613 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats))); 11614 Analyze (N); 11615 11616 -- Note: have to worry more about abort deferral in above code ??? 11617 11618 -- Final step is to unstack the Accept_Address entries for all accept 11619 -- statements appearing in accept alternatives in the select statement 11620 11621 Alt := First (Alts); 11622 while Present (Alt) loop 11623 if Nkind (Alt) = N_Accept_Alternative then 11624 Remove_Last_Elmt (Accept_Address 11625 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))); 11626 end if; 11627 11628 Next (Alt); 11629 end loop; 11630 end Expand_N_Selective_Accept; 11631 11632 ------------------------------------------- 11633 -- Expand_N_Single_Protected_Declaration -- 11634 ------------------------------------------- 11635 11636 -- A single protected declaration should never be present after semantic 11637 -- analysis because it is transformed into a protected type declaration 11638 -- and an accompanying anonymous object. This routine ensures that the 11639 -- transformation takes place. 11640 11641 procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is 11642 begin 11643 raise Program_Error; 11644 end Expand_N_Single_Protected_Declaration; 11645 11646 -------------------------------------- 11647 -- Expand_N_Single_Task_Declaration -- 11648 -------------------------------------- 11649 11650 -- A single task declaration should never be present after semantic 11651 -- analysis because it is transformed into a task type declaration and 11652 -- an accompanying anonymous object. This routine ensures that the 11653 -- transformation takes place. 11654 11655 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is 11656 begin 11657 raise Program_Error; 11658 end Expand_N_Single_Task_Declaration; 11659 11660 ------------------------ 11661 -- Expand_N_Task_Body -- 11662 ------------------------ 11663 11664 -- Given a task body 11665 11666 -- task body tname is 11667 -- <declarations> 11668 -- begin 11669 -- <statements> 11670 -- end x; 11671 11672 -- This expansion routine converts it into a procedure and sets the 11673 -- elaboration flag for the procedure to true, to represent the fact 11674 -- that the task body is now elaborated: 11675 11676 -- procedure tnameB (_Task : access tnameV) is 11677 -- discriminal : dtype renames _Task.discriminant; 11678 11679 -- procedure _clean is 11680 -- begin 11681 -- Abort_Defer.all; 11682 -- Complete_Task; 11683 -- Abort_Undefer.all; 11684 -- return; 11685 -- end _clean; 11686 11687 -- begin 11688 -- Abort_Undefer.all; 11689 -- <declarations> 11690 -- System.Task_Stages.Complete_Activation; 11691 -- <statements> 11692 -- at end 11693 -- _clean; 11694 -- end tnameB; 11695 11696 -- tnameE := True; 11697 11698 -- In addition, if the task body is an activator, then a call to activate 11699 -- tasks is added at the start of the statements, before the call to 11700 -- Complete_Activation, and if in addition the task is a master then it 11701 -- must be established as a master. These calls are inserted and analyzed 11702 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is 11703 -- expanded. 11704 11705 -- There is one discriminal declaration line generated for each 11706 -- discriminant that is present to provide an easy reference point for 11707 -- discriminant references inside the body (see Exp_Ch2.Expand_Name). 11708 11709 -- Note on relationship to GNARLI definition. In the GNARLI definition, 11710 -- task body procedures have a profile (Arg : System.Address). That is 11711 -- needed because GNARLI has to use the same access-to-subprogram type 11712 -- for all task types. We depend here on knowing that in GNAT, passing 11713 -- an address argument by value is identical to passing a record value 11714 -- by access (in either case a single pointer is passed), so even though 11715 -- this procedure has the wrong profile. In fact it's all OK, since the 11716 -- callings sequence is identical. 11717 11718 procedure Expand_N_Task_Body (N : Node_Id) is 11719 Loc : constant Source_Ptr := Sloc (N); 11720 Ttyp : constant Entity_Id := Corresponding_Spec (N); 11721 Call : Node_Id; 11722 New_N : Node_Id; 11723 11724 Insert_Nod : Node_Id; 11725 -- Used to determine the proper location of wrapper body insertions 11726 11727 begin 11728 -- if no task body procedure, means we had an error in configurable 11729 -- run-time mode, and there is no point in proceeding further. 11730 11731 if No (Task_Body_Procedure (Ttyp)) then 11732 return; 11733 end if; 11734 11735 -- Add renaming declarations for discriminals and a declaration for the 11736 -- entry family index (if applicable). 11737 11738 Install_Private_Data_Declarations 11739 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N)); 11740 11741 -- Add a call to Abort_Undefer at the very beginning of the task 11742 -- body since this body is called with abort still deferred. 11743 11744 if Abort_Allowed then 11745 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 11746 Insert_Before 11747 (First (Statements (Handled_Statement_Sequence (N))), Call); 11748 Analyze (Call); 11749 end if; 11750 11751 -- The statement part has already been protected with an at_end and 11752 -- cleanup actions. The call to Complete_Activation must be placed 11753 -- at the head of the sequence of statements of that block. The 11754 -- declarations have been merged in this sequence of statements but 11755 -- the first real statement is accessible from the First_Real_Statement 11756 -- field (which was set for exactly this purpose). 11757 11758 if Restricted_Profile then 11759 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); 11760 else 11761 Call := Build_Runtime_Call (Loc, RE_Complete_Activation); 11762 end if; 11763 11764 Insert_Before 11765 (First_Real_Statement (Handled_Statement_Sequence (N)), Call); 11766 Analyze (Call); 11767 11768 New_N := 11769 Make_Subprogram_Body (Loc, 11770 Specification => Build_Task_Proc_Specification (Ttyp), 11771 Declarations => Declarations (N), 11772 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 11773 Set_Is_Task_Body_Procedure (New_N); 11774 11775 -- If the task contains generic instantiations, cleanup actions are 11776 -- delayed until after instantiation. Transfer the activation chain to 11777 -- the subprogram, to insure that the activation call is properly 11778 -- generated. It the task body contains inner tasks, indicate that the 11779 -- subprogram is a task master. 11780 11781 if Delay_Cleanups (Ttyp) then 11782 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); 11783 Set_Is_Task_Master (New_N, Is_Task_Master (N)); 11784 end if; 11785 11786 Rewrite (N, New_N); 11787 Analyze (N); 11788 11789 -- Set elaboration flag immediately after task body. If the body is a 11790 -- subunit, the flag is set in the declarative part containing the stub. 11791 11792 if Nkind (Parent (N)) /= N_Subunit then 11793 Insert_After (N, 11794 Make_Assignment_Statement (Loc, 11795 Name => 11796 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), 11797 Expression => New_Occurrence_Of (Standard_True, Loc))); 11798 end if; 11799 11800 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after 11801 -- the task body. At this point all wrapper specs have been created, 11802 -- frozen and included in the dispatch table for the task type. 11803 11804 if Ada_Version >= Ada_2005 then 11805 if Nkind (Parent (N)) = N_Subunit then 11806 Insert_Nod := Corresponding_Stub (Parent (N)); 11807 else 11808 Insert_Nod := N; 11809 end if; 11810 11811 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod); 11812 end if; 11813 end Expand_N_Task_Body; 11814 11815 ------------------------------------ 11816 -- Expand_N_Task_Type_Declaration -- 11817 ------------------------------------ 11818 11819 -- We have several things to do. First we must create a Boolean flag used 11820 -- to mark if the body is elaborated yet. This variable gets set to True 11821 -- when the body of the task is elaborated (we can't rely on the normal 11822 -- ABE mechanism for the task body, since we need to pass an access to 11823 -- this elaboration boolean to the runtime routines). 11824 11825 -- taskE : aliased Boolean := False; 11826 11827 -- Next a variable is declared to hold the task stack size (either the 11828 -- default : Unspecified_Size, or a value that is set by a pragma 11829 -- Storage_Size). If the value of the pragma Storage_Size is static, then 11830 -- the variable is initialized with this value: 11831 11832 -- taskZ : Size_Type := Unspecified_Size; 11833 -- or 11834 -- taskZ : Size_Type := Size_Type (size_expression); 11835 11836 -- Note: No variable is needed to hold the task relative deadline since 11837 -- its value would never be static because the parameter is of a private 11838 -- type (Ada.Real_Time.Time_Span). 11839 11840 -- Next we create a corresponding record type declaration used to represent 11841 -- values of this task. The general form of this type declaration is 11842 11843 -- type taskV (discriminants) is record 11844 -- _Task_Id : Task_Id; 11845 -- entry_family : array (bounds) of Void; 11846 -- _Priority : Integer := priority_expression; 11847 -- _Size : Size_Type := size_expression; 11848 -- _Secondary_Stack_Size : Size_Type := size_expression; 11849 -- _Task_Info : Task_Info_Type := task_info_expression; 11850 -- _CPU : Integer := cpu_range_expression; 11851 -- _Relative_Deadline : Time_Span := time_span_expression; 11852 -- _Domain : Dispatching_Domain := dd_expression; 11853 -- end record; 11854 11855 -- The discriminants are present only if the corresponding task type has 11856 -- discriminants, and they exactly mirror the task type discriminants. 11857 11858 -- The Id field is always present. It contains the Task_Id value, as set by 11859 -- the call to Create_Task. Note that although the task is limited, the 11860 -- task value record type is not limited, so there is no problem in passing 11861 -- this field as an out parameter to Create_Task. 11862 11863 -- One entry_family component is present for each entry family in the task 11864 -- definition. The bounds correspond to the bounds of the entry family 11865 -- (which may depend on discriminants). The element type is void, since we 11866 -- only need the bounds information for determining the entry index. Note 11867 -- that the use of an anonymous array would normally be illegal in this 11868 -- context, but this is a parser check, and the semantics is quite prepared 11869 -- to handle such a case. 11870 11871 -- The _Size field is present only if a Storage_Size pragma appears in the 11872 -- task definition. The expression captures the argument that was present 11873 -- in the pragma, and is used to override the task stack size otherwise 11874 -- associated with the task type. 11875 11876 -- The _Secondary_Stack_Size field is present only the task entity has a 11877 -- Secondary_Stack_Size rep item. It will be filled at the freeze point, 11878 -- when the record init proc is built, to capture the expression of the 11879 -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot 11880 -- be filled here since aspect evaluations are delayed till the freeze 11881 -- point. 11882 11883 -- The _Priority field is present only if the task entity has a Priority or 11884 -- Interrupt_Priority rep item (pragma, aspect specification or attribute 11885 -- definition clause). It will be filled at the freeze point, when the 11886 -- record init proc is built, to capture the expression of the rep item 11887 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11888 -- here since aspect evaluations are delayed till the freeze point. 11889 11890 -- The _Task_Info field is present only if a Task_Info pragma appears in 11891 -- the task definition. The expression captures the argument that was 11892 -- present in the pragma, and is used to provide the Task_Image parameter 11893 -- to the call to Create_Task. 11894 11895 -- The _CPU field is present only if the task entity has a CPU rep item 11896 -- (pragma, aspect specification or attribute definition clause). It will 11897 -- be filled at the freeze point, when the record init proc is built, to 11898 -- capture the expression of the rep item (see Build_Record_Init_Proc in 11899 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations 11900 -- are delayed till the freeze point. 11901 11902 -- The _Relative_Deadline field is present only if a Relative_Deadline 11903 -- pragma appears in the task definition. The expression captures the 11904 -- argument that was present in the pragma, and is used to provide the 11905 -- Relative_Deadline parameter to the call to Create_Task. 11906 11907 -- The _Domain field is present only if the task entity has a 11908 -- Dispatching_Domain rep item (pragma, aspect specification or attribute 11909 -- definition clause). It will be filled at the freeze point, when the 11910 -- record init proc is built, to capture the expression of the rep item 11911 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11912 -- here since aspect evaluations are delayed till the freeze point. 11913 11914 -- When a task is declared, an instance of the task value record is 11915 -- created. The elaboration of this declaration creates the correct bounds 11916 -- for the entry families, and also evaluates the size, priority, and 11917 -- task_Info expressions if needed. The initialization routine for the task 11918 -- type itself then calls Create_Task with appropriate parameters to 11919 -- initialize the value of the Task_Id field. 11920 11921 -- Note: the address of this record is passed as the "Discriminants" 11922 -- parameter for Create_Task. Since Create_Task merely passes this onto the 11923 -- body procedure, it does not matter that it does not quite match the 11924 -- GNARLI model of what is being passed (the record contains more than just 11925 -- the discriminants, but the discriminants can be found from the record 11926 -- value). 11927 11928 -- The Entity_Id for this created record type is placed in the 11929 -- Corresponding_Record_Type field of the associated task type entity. 11930 11931 -- Next we create a procedure specification for the task body procedure: 11932 11933 -- procedure taskB (_Task : access taskV); 11934 11935 -- Note that this must come after the record type declaration, since 11936 -- the spec refers to this type. It turns out that the initialization 11937 -- procedure for the value type references the task body spec, but that's 11938 -- fine, since it won't be generated till the freeze point for the type, 11939 -- which is certainly after the task body spec declaration. 11940 11941 -- Finally, we set the task index value field of the entry attribute in 11942 -- the case of a simple entry. 11943 11944 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is 11945 Loc : constant Source_Ptr := Sloc (N); 11946 TaskId : constant Entity_Id := Defining_Identifier (N); 11947 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); 11948 Tasknm : constant Name_Id := Chars (Tasktyp); 11949 Taskdef : constant Node_Id := Task_Definition (N); 11950 11951 Body_Decl : Node_Id; 11952 Cdecls : List_Id; 11953 Decl_Stack : Node_Id; 11954 Decl_SS : Node_Id; 11955 Elab_Decl : Node_Id; 11956 Ent_Stack : Entity_Id; 11957 Proc_Spec : Node_Id; 11958 Rec_Decl : Node_Id; 11959 Rec_Ent : Entity_Id; 11960 Size_Decl : Entity_Id; 11961 Task_Size : Node_Id; 11962 11963 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id; 11964 -- Searches the task definition T for the first occurrence of the pragma 11965 -- Relative Deadline. The caller has ensured that the pragma is present 11966 -- in the task definition. Note that this routine cannot be implemented 11967 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are 11968 -- not chained because their expansion into a procedure call statement 11969 -- would cause a break in the chain. 11970 11971 ---------------------------------- 11972 -- Get_Relative_Deadline_Pragma -- 11973 ---------------------------------- 11974 11975 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is 11976 N : Node_Id; 11977 11978 begin 11979 N := First (Visible_Declarations (T)); 11980 while Present (N) loop 11981 if Nkind (N) = N_Pragma 11982 and then Pragma_Name (N) = Name_Relative_Deadline 11983 then 11984 return N; 11985 end if; 11986 11987 Next (N); 11988 end loop; 11989 11990 N := First (Private_Declarations (T)); 11991 while Present (N) loop 11992 if Nkind (N) = N_Pragma 11993 and then Pragma_Name (N) = Name_Relative_Deadline 11994 then 11995 return N; 11996 end if; 11997 11998 Next (N); 11999 end loop; 12000 12001 raise Program_Error; 12002 end Get_Relative_Deadline_Pragma; 12003 12004 -- Start of processing for Expand_N_Task_Type_Declaration 12005 12006 begin 12007 -- If already expanded, nothing to do 12008 12009 if Present (Corresponding_Record_Type (Tasktyp)) then 12010 return; 12011 end if; 12012 12013 -- Here we will do the expansion 12014 12015 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); 12016 12017 Rec_Ent := Defining_Identifier (Rec_Decl); 12018 Cdecls := Component_Items (Component_List 12019 (Type_Definition (Rec_Decl))); 12020 12021 Qualify_Entity_Names (N); 12022 12023 -- First create the elaboration variable 12024 12025 Elab_Decl := 12026 Make_Object_Declaration (Loc, 12027 Defining_Identifier => 12028 Make_Defining_Identifier (Sloc (Tasktyp), 12029 Chars => New_External_Name (Tasknm, 'E')), 12030 Aliased_Present => True, 12031 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 12032 Expression => New_Occurrence_Of (Standard_False, Loc)); 12033 12034 Insert_After (N, Elab_Decl); 12035 12036 -- Next create the declaration of the size variable (tasknmZ) 12037 12038 Set_Storage_Size_Variable (Tasktyp, 12039 Make_Defining_Identifier (Sloc (Tasktyp), 12040 Chars => New_External_Name (Tasknm, 'Z'))); 12041 12042 if Present (Taskdef) 12043 and then Has_Storage_Size_Pragma (Taskdef) 12044 and then 12045 Is_OK_Static_Expression 12046 (Expression 12047 (First (Pragma_Argument_Associations 12048 (Get_Rep_Pragma (TaskId, Name_Storage_Size))))) 12049 then 12050 Size_Decl := 12051 Make_Object_Declaration (Loc, 12052 Defining_Identifier => Storage_Size_Variable (Tasktyp), 12053 Object_Definition => 12054 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 12055 Expression => 12056 Convert_To (RTE (RE_Size_Type), 12057 Relocate_Node 12058 (Expression (First (Pragma_Argument_Associations 12059 (Get_Rep_Pragma 12060 (TaskId, Name_Storage_Size))))))); 12061 12062 else 12063 Size_Decl := 12064 Make_Object_Declaration (Loc, 12065 Defining_Identifier => Storage_Size_Variable (Tasktyp), 12066 Object_Definition => 12067 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 12068 Expression => 12069 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 12070 end if; 12071 12072 Insert_After (Elab_Decl, Size_Decl); 12073 12074 -- Next build the rest of the corresponding record declaration. This is 12075 -- done last, since the corresponding record initialization procedure 12076 -- will reference the previously created entities. 12077 12078 -- Fill in the component declarations -- first the _Task_Id field 12079 12080 Append_To (Cdecls, 12081 Make_Component_Declaration (Loc, 12082 Defining_Identifier => 12083 Make_Defining_Identifier (Loc, Name_uTask_Id), 12084 Component_Definition => 12085 Make_Component_Definition (Loc, 12086 Aliased_Present => False, 12087 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id), 12088 Loc)))); 12089 12090 -- Declare static ATCB (that is, created by the expander) if we are 12091 -- using the Restricted run time. 12092 12093 if Restricted_Profile then 12094 Append_To (Cdecls, 12095 Make_Component_Declaration (Loc, 12096 Defining_Identifier => 12097 Make_Defining_Identifier (Loc, Name_uATCB), 12098 12099 Component_Definition => 12100 Make_Component_Definition (Loc, 12101 Aliased_Present => True, 12102 Subtype_Indication => Make_Subtype_Indication (Loc, 12103 Subtype_Mark => 12104 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc), 12105 12106 Constraint => 12107 Make_Index_Or_Discriminant_Constraint (Loc, 12108 Constraints => 12109 New_List (Make_Integer_Literal (Loc, 0))))))); 12110 12111 end if; 12112 12113 -- Declare static stack (that is, created by the expander) if we are 12114 -- using the Restricted run time on a bare board configuration. 12115 12116 if Restricted_Profile and then Preallocated_Stacks_On_Target then 12117 12118 -- First we need to extract the appropriate stack size 12119 12120 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack); 12121 12122 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 12123 declare 12124 Expr_N : constant Node_Id := 12125 Expression (First ( 12126 Pragma_Argument_Associations ( 12127 Get_Rep_Pragma (TaskId, Name_Storage_Size)))); 12128 Etyp : constant Entity_Id := Etype (Expr_N); 12129 P : constant Node_Id := Parent (Expr_N); 12130 12131 begin 12132 -- The stack is defined inside the corresponding record. 12133 -- Therefore if the size of the stack is set by means of 12134 -- a discriminant, we must reference the discriminant of the 12135 -- corresponding record type. 12136 12137 if Nkind (Expr_N) in N_Has_Entity 12138 and then Present (Discriminal_Link (Entity (Expr_N))) 12139 then 12140 Task_Size := 12141 New_Occurrence_Of 12142 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))), 12143 Loc); 12144 Set_Parent (Task_Size, P); 12145 Set_Etype (Task_Size, Etyp); 12146 Set_Analyzed (Task_Size); 12147 12148 else 12149 Task_Size := New_Copy_Tree (Expr_N); 12150 end if; 12151 end; 12152 12153 else 12154 Task_Size := 12155 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc); 12156 end if; 12157 12158 Decl_Stack := Make_Component_Declaration (Loc, 12159 Defining_Identifier => Ent_Stack, 12160 12161 Component_Definition => 12162 Make_Component_Definition (Loc, 12163 Aliased_Present => True, 12164 Subtype_Indication => Make_Subtype_Indication (Loc, 12165 Subtype_Mark => 12166 New_Occurrence_Of (RTE (RE_Storage_Array), Loc), 12167 12168 Constraint => 12169 Make_Index_Or_Discriminant_Constraint (Loc, 12170 Constraints => New_List (Make_Range (Loc, 12171 Low_Bound => Make_Integer_Literal (Loc, 1), 12172 High_Bound => Convert_To (RTE (RE_Storage_Offset), 12173 Task_Size))))))); 12174 12175 Append_To (Cdecls, Decl_Stack); 12176 12177 -- The appropriate alignment for the stack is ensured by the run-time 12178 -- code in charge of task creation. 12179 12180 end if; 12181 12182 -- Declare a static secondary stack if the conditions for a statically 12183 -- generated stack are met. 12184 12185 if Create_Secondary_Stack_For_Task (TaskId) then 12186 declare 12187 Size_Expr : constant Node_Id := 12188 Expression (First ( 12189 Pragma_Argument_Associations ( 12190 Get_Rep_Pragma (TaskId, 12191 Name_Secondary_Stack_Size)))); 12192 12193 Stack_Size : Node_Id; 12194 12195 begin 12196 -- The secondary stack is defined inside the corresponding 12197 -- record. Therefore if the size of the stack is set by means 12198 -- of a discriminant, we must reference the discriminant of the 12199 -- corresponding record type. 12200 12201 if Nkind (Size_Expr) in N_Has_Entity 12202 and then Present (Discriminal_Link (Entity (Size_Expr))) 12203 then 12204 Stack_Size := 12205 New_Occurrence_Of 12206 (CR_Discriminant (Discriminal_Link (Entity (Size_Expr))), 12207 Loc); 12208 Set_Parent (Stack_Size, Parent (Size_Expr)); 12209 Set_Etype (Stack_Size, Etype (Size_Expr)); 12210 Set_Analyzed (Stack_Size); 12211 12212 else 12213 Stack_Size := New_Copy_Tree (Size_Expr); 12214 end if; 12215 12216 -- Create the secondary stack for the task 12217 12218 Decl_SS := 12219 Make_Component_Declaration (Loc, 12220 Defining_Identifier => 12221 Make_Defining_Identifier (Loc, Name_uSecondary_Stack), 12222 Component_Definition => 12223 Make_Component_Definition (Loc, 12224 Aliased_Present => True, 12225 Subtype_Indication => 12226 Make_Subtype_Indication (Loc, 12227 Subtype_Mark => 12228 New_Occurrence_Of (RTE (RE_SS_Stack), Loc), 12229 Constraint => 12230 Make_Index_Or_Discriminant_Constraint (Loc, 12231 Constraints => New_List ( 12232 Convert_To (RTE (RE_Size_Type), 12233 Stack_Size)))))); 12234 12235 Append_To (Cdecls, Decl_SS); 12236 end; 12237 end if; 12238 12239 -- Add components for entry families 12240 12241 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); 12242 12243 -- Add the _Priority component if a Interrupt_Priority or Priority rep 12244 -- item is present. 12245 12246 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then 12247 Append_To (Cdecls, 12248 Make_Component_Declaration (Loc, 12249 Defining_Identifier => 12250 Make_Defining_Identifier (Loc, Name_uPriority), 12251 Component_Definition => 12252 Make_Component_Definition (Loc, 12253 Aliased_Present => False, 12254 Subtype_Indication => 12255 New_Occurrence_Of (Standard_Integer, Loc)))); 12256 end if; 12257 12258 -- Add the _Size component if a Storage_Size pragma is present 12259 12260 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 12261 Append_To (Cdecls, 12262 Make_Component_Declaration (Loc, 12263 Defining_Identifier => 12264 Make_Defining_Identifier (Loc, Name_uSize), 12265 12266 Component_Definition => 12267 Make_Component_Definition (Loc, 12268 Aliased_Present => False, 12269 Subtype_Indication => 12270 New_Occurrence_Of (RTE (RE_Size_Type), Loc)), 12271 12272 Expression => 12273 Convert_To (RTE (RE_Size_Type), 12274 New_Copy_Tree ( 12275 Expression (First ( 12276 Pragma_Argument_Associations ( 12277 Get_Rep_Pragma (TaskId, Name_Storage_Size)))))))); 12278 end if; 12279 12280 -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size 12281 -- pragma is present. 12282 12283 if Has_Rep_Pragma 12284 (TaskId, Name_Secondary_Stack_Size, Check_Parents => False) 12285 then 12286 Append_To (Cdecls, 12287 Make_Component_Declaration (Loc, 12288 Defining_Identifier => 12289 Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size), 12290 12291 Component_Definition => 12292 Make_Component_Definition (Loc, 12293 Aliased_Present => False, 12294 Subtype_Indication => 12295 New_Occurrence_Of (RTE (RE_Size_Type), Loc)))); 12296 end if; 12297 12298 -- Add the _Task_Info component if a Task_Info pragma is present 12299 12300 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then 12301 Append_To (Cdecls, 12302 Make_Component_Declaration (Loc, 12303 Defining_Identifier => 12304 Make_Defining_Identifier (Loc, Name_uTask_Info), 12305 12306 Component_Definition => 12307 Make_Component_Definition (Loc, 12308 Aliased_Present => False, 12309 Subtype_Indication => 12310 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)), 12311 12312 Expression => New_Copy ( 12313 Expression (First ( 12314 Pragma_Argument_Associations ( 12315 Get_Rep_Pragma 12316 (TaskId, Name_Task_Info, Check_Parents => False))))))); 12317 end if; 12318 12319 -- Add the _CPU component if a CPU rep item is present 12320 12321 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then 12322 Append_To (Cdecls, 12323 Make_Component_Declaration (Loc, 12324 Defining_Identifier => 12325 Make_Defining_Identifier (Loc, Name_uCPU), 12326 12327 Component_Definition => 12328 Make_Component_Definition (Loc, 12329 Aliased_Present => False, 12330 Subtype_Indication => 12331 New_Occurrence_Of (RTE (RE_CPU_Range), Loc)))); 12332 end if; 12333 12334 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is 12335 -- present. If we are using a restricted run time this component will 12336 -- not be added (deadlines are not allowed by the Ravenscar profile), 12337 -- unless the task dispatching policy is EDF (for GNAT_Ravenscar_EDF 12338 -- profile). 12339 12340 if (not Restricted_Profile or else Task_Dispatching_Policy = 'E') 12341 and then Present (Taskdef) 12342 and then Has_Relative_Deadline_Pragma (Taskdef) 12343 then 12344 Append_To (Cdecls, 12345 Make_Component_Declaration (Loc, 12346 Defining_Identifier => 12347 Make_Defining_Identifier (Loc, Name_uRelative_Deadline), 12348 12349 Component_Definition => 12350 Make_Component_Definition (Loc, 12351 Aliased_Present => False, 12352 Subtype_Indication => 12353 New_Occurrence_Of (RTE (RE_Time_Span), Loc)), 12354 12355 Expression => 12356 Convert_To (RTE (RE_Time_Span), 12357 New_Copy_Tree ( 12358 Expression (First ( 12359 Pragma_Argument_Associations ( 12360 Get_Relative_Deadline_Pragma (Taskdef)))))))); 12361 end if; 12362 12363 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep 12364 -- item is present. If we are using a restricted run time this component 12365 -- will not be added (dispatching domains are not allowed by the 12366 -- Ravenscar profile). 12367 12368 if not Restricted_Profile 12369 and then 12370 Has_Rep_Item 12371 (TaskId, Name_Dispatching_Domain, Check_Parents => False) 12372 then 12373 Append_To (Cdecls, 12374 Make_Component_Declaration (Loc, 12375 Defining_Identifier => 12376 Make_Defining_Identifier (Loc, Name_uDispatching_Domain), 12377 12378 Component_Definition => 12379 Make_Component_Definition (Loc, 12380 Aliased_Present => False, 12381 Subtype_Indication => 12382 New_Occurrence_Of 12383 (RTE (RE_Dispatching_Domain_Access), Loc)))); 12384 end if; 12385 12386 Insert_After (Size_Decl, Rec_Decl); 12387 12388 -- Analyze the record declaration immediately after construction, 12389 -- because the initialization procedure is needed for single task 12390 -- declarations before the next entity is analyzed. 12391 12392 Analyze (Rec_Decl); 12393 12394 -- Create the declaration of the task body procedure 12395 12396 Proc_Spec := Build_Task_Proc_Specification (Tasktyp); 12397 Body_Decl := 12398 Make_Subprogram_Declaration (Loc, 12399 Specification => Proc_Spec); 12400 Set_Is_Task_Body_Procedure (Body_Decl); 12401 12402 Insert_After (Rec_Decl, Body_Decl); 12403 12404 -- The subprogram does not comes from source, so we have to indicate the 12405 -- need for debugging information explicitly. 12406 12407 if Comes_From_Source (Original_Node (N)) then 12408 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec)); 12409 end if; 12410 12411 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before 12412 -- the corresponding record has been frozen. 12413 12414 if Ada_Version >= Ada_2005 then 12415 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl); 12416 end if; 12417 12418 -- Ada 2005 (AI-345): We must defer freezing to allow further 12419 -- declaration of primitive subprograms covering task interfaces 12420 12421 if Ada_Version <= Ada_95 then 12422 12423 -- Now we can freeze the corresponding record. This needs manually 12424 -- freezing, since it is really part of the task type, and the task 12425 -- type is frozen at this stage. We of course need the initialization 12426 -- procedure for this corresponding record type and we won't get it 12427 -- in time if we don't freeze now. 12428 12429 declare 12430 L : constant List_Id := Freeze_Entity (Rec_Ent, N); 12431 begin 12432 if Is_Non_Empty_List (L) then 12433 Insert_List_After (Body_Decl, L); 12434 end if; 12435 end; 12436 end if; 12437 12438 -- Complete the expansion of access types to the current task type, if 12439 -- any were declared. 12440 12441 Expand_Previous_Access_Type (Tasktyp); 12442 12443 -- Create wrappers for entries that have contract cases, preconditions 12444 -- and postconditions. 12445 12446 declare 12447 Ent : Entity_Id; 12448 12449 begin 12450 Ent := First_Entity (Tasktyp); 12451 while Present (Ent) loop 12452 if Ekind_In (Ent, E_Entry, E_Entry_Family) then 12453 Build_Contract_Wrapper (Ent, N); 12454 end if; 12455 12456 Next_Entity (Ent); 12457 end loop; 12458 end; 12459 end Expand_N_Task_Type_Declaration; 12460 12461 ------------------------------- 12462 -- Expand_N_Timed_Entry_Call -- 12463 ------------------------------- 12464 12465 -- A timed entry call in normal case is not implemented using ATC mechanism 12466 -- anymore for efficiency reason. 12467 12468 -- select 12469 -- T.E; 12470 -- S1; 12471 -- or 12472 -- delay D; 12473 -- S2; 12474 -- end select; 12475 12476 -- is expanded as follows: 12477 12478 -- 1) When T.E is a task entry_call; 12479 12480 -- declare 12481 -- B : Boolean; 12482 -- X : Task_Entry_Index := <entry index>; 12483 -- DX : Duration := To_Duration (D); 12484 -- M : Delay_Mode := <discriminant>; 12485 -- P : parms := (parm, parm, parm); 12486 12487 -- begin 12488 -- Timed_Protected_Entry_Call 12489 -- (<acceptor-task>, X, P'Address, DX, M, B); 12490 -- if B then 12491 -- S1; 12492 -- else 12493 -- S2; 12494 -- end if; 12495 -- end; 12496 12497 -- 2) When T.E is a protected entry_call; 12498 12499 -- declare 12500 -- B : Boolean; 12501 -- X : Protected_Entry_Index := <entry index>; 12502 -- DX : Duration := To_Duration (D); 12503 -- M : Delay_Mode := <discriminant>; 12504 -- P : parms := (parm, parm, parm); 12505 12506 -- begin 12507 -- Timed_Protected_Entry_Call 12508 -- (<object>'unchecked_access, X, P'Address, DX, M, B); 12509 -- if B then 12510 -- S1; 12511 -- else 12512 -- S2; 12513 -- end if; 12514 -- end; 12515 12516 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there 12517 -- is no delay and the triggering statements are executed. We first 12518 -- determine the kind of the triggering call and then execute a 12519 -- synchronized operation or a direct call. 12520 12521 -- declare 12522 -- B : Boolean := False; 12523 -- C : Ada.Tags.Prim_Op_Kind; 12524 -- DX : Duration := To_Duration (D) 12525 -- K : Ada.Tags.Tagged_Kind := 12526 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 12527 -- M : Integer :=...; 12528 -- P : Parameters := (Param1 .. ParamN); 12529 -- S : Integer; 12530 12531 -- begin 12532 -- if K = Ada.Tags.TK_Limited_Tagged 12533 -- or else K = Ada.Tags.TK_Tagged 12534 -- then 12535 -- <dispatching-call>; 12536 -- B := True; 12537 12538 -- else 12539 -- S := 12540 -- Ada.Tags.Get_Offset_Index 12541 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 12542 12543 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B); 12544 12545 -- if C = POK_Protected_Entry 12546 -- or else C = POK_Task_Entry 12547 -- then 12548 -- Param1 := P.Param1; 12549 -- ... 12550 -- ParamN := P.ParamN; 12551 -- end if; 12552 12553 -- if B then 12554 -- if C = POK_Procedure 12555 -- or else C = POK_Protected_Procedure 12556 -- or else C = POK_Task_Procedure 12557 -- then 12558 -- <dispatching-call>; 12559 -- end if; 12560 -- end if; 12561 -- end if; 12562 12563 -- if B then 12564 -- <triggering-statements> 12565 -- else 12566 -- <timed-statements> 12567 -- end if; 12568 -- end; 12569 12570 -- The triggering statement and the sequence of timed statements have not 12571 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain 12572 -- global references if within an instantiation. 12573 12574 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is 12575 Loc : constant Source_Ptr := Sloc (N); 12576 12577 Actuals : List_Id; 12578 Blk_Typ : Entity_Id; 12579 Call : Node_Id; 12580 Call_Ent : Entity_Id; 12581 Conc_Typ_Stmts : List_Id; 12582 Concval : Node_Id := Empty; -- init to avoid warning 12583 D_Alt : constant Node_Id := Delay_Alternative (N); 12584 D_Conv : Node_Id; 12585 D_Disc : Node_Id; 12586 D_Stat : Node_Id := Delay_Statement (D_Alt); 12587 D_Stats : List_Id; 12588 D_Type : Entity_Id; 12589 Decls : List_Id; 12590 Dummy : Node_Id; 12591 E_Alt : constant Node_Id := Entry_Call_Alternative (N); 12592 E_Call : Node_Id := Entry_Call_Statement (E_Alt); 12593 E_Stats : List_Id; 12594 Ename : Node_Id; 12595 Formals : List_Id; 12596 Index : Node_Id; 12597 Is_Disp_Select : Boolean; 12598 Lim_Typ_Stmts : List_Id; 12599 N_Stats : List_Id; 12600 Obj : Entity_Id; 12601 Param : Node_Id; 12602 Params : List_Id; 12603 Stmt : Node_Id; 12604 Stmts : List_Id; 12605 Unpack : List_Id; 12606 12607 B : Entity_Id; -- Call status flag 12608 C : Entity_Id; -- Call kind 12609 D : Entity_Id; -- Delay 12610 K : Entity_Id; -- Tagged kind 12611 M : Entity_Id; -- Delay mode 12612 P : Entity_Id; -- Parameter block 12613 S : Entity_Id; -- Primitive operation slot 12614 12615 -- Start of processing for Expand_N_Timed_Entry_Call 12616 12617 begin 12618 -- Under the Ravenscar profile, timed entry calls are excluded. An error 12619 -- was already reported on spec, so do not attempt to expand the call. 12620 12621 if Restriction_Active (No_Select_Statements) then 12622 return; 12623 end if; 12624 12625 Process_Statements_For_Controlled_Objects (E_Alt); 12626 Process_Statements_For_Controlled_Objects (D_Alt); 12627 12628 Ensure_Statement_Present (Sloc (D_Stat), D_Alt); 12629 12630 -- Retrieve E_Stats and D_Stats now because the finalization machinery 12631 -- may wrap them in blocks. 12632 12633 E_Stats := Statements (E_Alt); 12634 D_Stats := Statements (D_Alt); 12635 12636 -- The arguments in the call may require dynamic allocation, and the 12637 -- call statement may have been transformed into a block. The block 12638 -- may contain additional declarations for internal entities, and the 12639 -- original call is found by sequential search. 12640 12641 if Nkind (E_Call) = N_Block_Statement then 12642 E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); 12643 while not Nkind_In (E_Call, N_Procedure_Call_Statement, 12644 N_Entry_Call_Statement) 12645 loop 12646 Next (E_Call); 12647 end loop; 12648 end if; 12649 12650 Is_Disp_Select := 12651 Ada_Version >= Ada_2005 12652 and then Nkind (E_Call) = N_Procedure_Call_Statement; 12653 12654 if Is_Disp_Select then 12655 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals); 12656 Decls := New_List; 12657 12658 Stmts := New_List; 12659 12660 -- Generate: 12661 -- B : Boolean := False; 12662 12663 B := Build_B (Loc, Decls); 12664 12665 -- Generate: 12666 -- C : Ada.Tags.Prim_Op_Kind; 12667 12668 C := Build_C (Loc, Decls); 12669 12670 -- Because the analysis of all statements was disabled, manually 12671 -- analyze the delay statement. 12672 12673 Analyze (D_Stat); 12674 D_Stat := Original_Node (D_Stat); 12675 12676 else 12677 -- Build an entry call using Simple_Entry_Call 12678 12679 Extract_Entry (E_Call, Concval, Ename, Index); 12680 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); 12681 12682 Decls := Declarations (E_Call); 12683 Stmts := Statements (Handled_Statement_Sequence (E_Call)); 12684 12685 if No (Decls) then 12686 Decls := New_List; 12687 end if; 12688 12689 -- Generate: 12690 -- B : Boolean; 12691 12692 B := Make_Defining_Identifier (Loc, Name_uB); 12693 12694 Prepend_To (Decls, 12695 Make_Object_Declaration (Loc, 12696 Defining_Identifier => B, 12697 Object_Definition => 12698 New_Occurrence_Of (Standard_Boolean, Loc))); 12699 end if; 12700 12701 -- Duration and mode processing 12702 12703 D_Type := Base_Type (Etype (Expression (D_Stat))); 12704 12705 -- Use the type of the delay expression (Calendar or Real_Time) to 12706 -- generate the appropriate conversion. 12707 12708 if Nkind (D_Stat) = N_Delay_Relative_Statement then 12709 D_Disc := Make_Integer_Literal (Loc, 0); 12710 D_Conv := Relocate_Node (Expression (D_Stat)); 12711 12712 elsif Is_RTE (D_Type, RO_CA_Time) then 12713 D_Disc := Make_Integer_Literal (Loc, 1); 12714 D_Conv := 12715 Make_Function_Call (Loc, 12716 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 12717 Parameter_Associations => 12718 New_List (New_Copy (Expression (D_Stat)))); 12719 12720 else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); 12721 D_Disc := Make_Integer_Literal (Loc, 2); 12722 D_Conv := 12723 Make_Function_Call (Loc, 12724 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 12725 Parameter_Associations => 12726 New_List (New_Copy (Expression (D_Stat)))); 12727 end if; 12728 12729 D := Make_Temporary (Loc, 'D'); 12730 12731 -- Generate: 12732 -- D : Duration; 12733 12734 Append_To (Decls, 12735 Make_Object_Declaration (Loc, 12736 Defining_Identifier => D, 12737 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc))); 12738 12739 M := Make_Temporary (Loc, 'M'); 12740 12741 -- Generate: 12742 -- M : Integer := (0 | 1 | 2); 12743 12744 Append_To (Decls, 12745 Make_Object_Declaration (Loc, 12746 Defining_Identifier => M, 12747 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 12748 Expression => D_Disc)); 12749 12750 -- Parameter block processing 12751 12752 -- Manually create the parameter block for dispatching calls. In the 12753 -- case of entries, the block has already been created during the call 12754 -- to Build_Simple_Entry_Call. 12755 12756 if Is_Disp_Select then 12757 12758 -- Compute the delay at this stage because the evaluation of its 12759 -- expression must not occur earlier (see ACVC C97302A). 12760 12761 Append_To (Stmts, 12762 Make_Assignment_Statement (Loc, 12763 Name => New_Occurrence_Of (D, Loc), 12764 Expression => D_Conv)); 12765 12766 -- Tagged kind processing, generate: 12767 -- K : Ada.Tags.Tagged_Kind := 12768 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>)); 12769 12770 K := Build_K (Loc, Decls, Obj); 12771 12772 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 12773 P := 12774 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 12775 12776 -- Dispatch table slot processing, generate: 12777 -- S : Integer; 12778 12779 S := Build_S (Loc, Decls); 12780 12781 -- Generate: 12782 -- S := Ada.Tags.Get_Offset_Index 12783 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 12784 12785 Conc_Typ_Stmts := 12786 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 12787 12788 -- Generate: 12789 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B); 12790 12791 -- where Obj is the controlling formal parameter, S is the dispatch 12792 -- table slot number of the dispatching operation, P is the wrapped 12793 -- parameter block, D is the duration, M is the duration mode, C is 12794 -- the call kind and B is the call status. 12795 12796 Params := New_List; 12797 12798 Append_To (Params, New_Copy_Tree (Obj)); 12799 Append_To (Params, New_Occurrence_Of (S, Loc)); 12800 Append_To (Params, 12801 Make_Attribute_Reference (Loc, 12802 Prefix => New_Occurrence_Of (P, Loc), 12803 Attribute_Name => Name_Address)); 12804 Append_To (Params, New_Occurrence_Of (D, Loc)); 12805 Append_To (Params, New_Occurrence_Of (M, Loc)); 12806 Append_To (Params, New_Occurrence_Of (C, Loc)); 12807 Append_To (Params, New_Occurrence_Of (B, Loc)); 12808 12809 Append_To (Conc_Typ_Stmts, 12810 Make_Procedure_Call_Statement (Loc, 12811 Name => 12812 New_Occurrence_Of 12813 (Find_Prim_Op 12814 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc), 12815 Parameter_Associations => Params)); 12816 12817 -- Generate: 12818 -- if C = POK_Protected_Entry 12819 -- or else C = POK_Task_Entry 12820 -- then 12821 -- Param1 := P.Param1; 12822 -- ... 12823 -- ParamN := P.ParamN; 12824 -- end if; 12825 12826 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 12827 12828 -- Generate the if statement only when the packed parameters need 12829 -- explicit assignments to their corresponding actuals. 12830 12831 if Present (Unpack) then 12832 Append_To (Conc_Typ_Stmts, 12833 Make_Implicit_If_Statement (N, 12834 12835 Condition => 12836 Make_Or_Else (Loc, 12837 Left_Opnd => 12838 Make_Op_Eq (Loc, 12839 Left_Opnd => New_Occurrence_Of (C, Loc), 12840 Right_Opnd => 12841 New_Occurrence_Of 12842 (RTE (RE_POK_Protected_Entry), Loc)), 12843 12844 Right_Opnd => 12845 Make_Op_Eq (Loc, 12846 Left_Opnd => New_Occurrence_Of (C, Loc), 12847 Right_Opnd => 12848 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 12849 12850 Then_Statements => Unpack)); 12851 end if; 12852 12853 -- Generate: 12854 12855 -- if B then 12856 -- if C = POK_Procedure 12857 -- or else C = POK_Protected_Procedure 12858 -- or else C = POK_Task_Procedure 12859 -- then 12860 -- <dispatching-call> 12861 -- end if; 12862 -- end if; 12863 12864 N_Stats := New_List ( 12865 Make_Implicit_If_Statement (N, 12866 Condition => 12867 Make_Or_Else (Loc, 12868 Left_Opnd => 12869 Make_Op_Eq (Loc, 12870 Left_Opnd => New_Occurrence_Of (C, Loc), 12871 Right_Opnd => 12872 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 12873 12874 Right_Opnd => 12875 Make_Or_Else (Loc, 12876 Left_Opnd => 12877 Make_Op_Eq (Loc, 12878 Left_Opnd => New_Occurrence_Of (C, Loc), 12879 Right_Opnd => 12880 New_Occurrence_Of (RTE ( 12881 RE_POK_Protected_Procedure), Loc)), 12882 Right_Opnd => 12883 Make_Op_Eq (Loc, 12884 Left_Opnd => New_Occurrence_Of (C, Loc), 12885 Right_Opnd => 12886 New_Occurrence_Of 12887 (RTE (RE_POK_Task_Procedure), Loc)))), 12888 12889 Then_Statements => New_List (E_Call))); 12890 12891 Append_To (Conc_Typ_Stmts, 12892 Make_Implicit_If_Statement (N, 12893 Condition => New_Occurrence_Of (B, Loc), 12894 Then_Statements => N_Stats)); 12895 12896 -- Generate: 12897 -- <dispatching-call>; 12898 -- B := True; 12899 12900 Lim_Typ_Stmts := 12901 New_List (New_Copy_Tree (E_Call), 12902 Make_Assignment_Statement (Loc, 12903 Name => New_Occurrence_Of (B, Loc), 12904 Expression => New_Occurrence_Of (Standard_True, Loc))); 12905 12906 -- Generate: 12907 -- if K = Ada.Tags.TK_Limited_Tagged 12908 -- or else K = Ada.Tags.TK_Tagged 12909 -- then 12910 -- Lim_Typ_Stmts 12911 -- else 12912 -- Conc_Typ_Stmts 12913 -- end if; 12914 12915 Append_To (Stmts, 12916 Make_Implicit_If_Statement (N, 12917 Condition => Build_Dispatching_Tag_Check (K, N), 12918 Then_Statements => Lim_Typ_Stmts, 12919 Else_Statements => Conc_Typ_Stmts)); 12920 12921 -- Generate: 12922 12923 -- if B then 12924 -- <triggering-statements> 12925 -- else 12926 -- <timed-statements> 12927 -- end if; 12928 12929 Append_To (Stmts, 12930 Make_Implicit_If_Statement (N, 12931 Condition => New_Occurrence_Of (B, Loc), 12932 Then_Statements => E_Stats, 12933 Else_Statements => D_Stats)); 12934 12935 else 12936 -- Simple case of a nondispatching trigger. Skip assignments to 12937 -- temporaries created for in-out parameters. 12938 12939 -- This makes unwarranted assumptions about the shape of the expanded 12940 -- tree for the call, and should be cleaned up ??? 12941 12942 Stmt := First (Stmts); 12943 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 12944 Next (Stmt); 12945 end loop; 12946 12947 -- Compute the delay at this stage because the evaluation of 12948 -- its expression must not occur earlier (see ACVC C97302A). 12949 12950 Insert_Before (Stmt, 12951 Make_Assignment_Statement (Loc, 12952 Name => New_Occurrence_Of (D, Loc), 12953 Expression => D_Conv)); 12954 12955 Call := Stmt; 12956 Params := Parameter_Associations (Call); 12957 12958 -- For a protected type, we build a Timed_Protected_Entry_Call 12959 12960 if Is_Protected_Type (Etype (Concval)) then 12961 12962 -- Create a new call statement 12963 12964 Param := First (Params); 12965 while Present (Param) 12966 and then not Is_RTE (Etype (Param), RE_Call_Modes) 12967 loop 12968 Next (Param); 12969 end loop; 12970 12971 Dummy := Remove_Next (Next (Param)); 12972 12973 -- Remove garbage is following the Cancel_Param if present 12974 12975 Dummy := Next (Param); 12976 12977 -- Remove the mode of the Protected_Entry_Call call, then remove 12978 -- the Communication_Block of the Protected_Entry_Call call, and 12979 -- finally add Duration and a Delay_Mode parameter 12980 12981 pragma Assert (Present (Param)); 12982 Rewrite (Param, New_Occurrence_Of (D, Loc)); 12983 12984 Rewrite (Dummy, New_Occurrence_Of (M, Loc)); 12985 12986 -- Add a Boolean flag for successful entry call 12987 12988 Append_To (Params, New_Occurrence_Of (B, Loc)); 12989 12990 case Corresponding_Runtime_Package (Etype (Concval)) is 12991 when System_Tasking_Protected_Objects_Entries => 12992 Rewrite (Call, 12993 Make_Procedure_Call_Statement (Loc, 12994 Name => 12995 New_Occurrence_Of 12996 (RTE (RE_Timed_Protected_Entry_Call), Loc), 12997 Parameter_Associations => Params)); 12998 12999 when others => 13000 raise Program_Error; 13001 end case; 13002 13003 -- For the task case, build a Timed_Task_Entry_Call 13004 13005 else 13006 -- Create a new call statement 13007 13008 Append_To (Params, New_Occurrence_Of (D, Loc)); 13009 Append_To (Params, New_Occurrence_Of (M, Loc)); 13010 Append_To (Params, New_Occurrence_Of (B, Loc)); 13011 13012 Rewrite (Call, 13013 Make_Procedure_Call_Statement (Loc, 13014 Name => 13015 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc), 13016 Parameter_Associations => Params)); 13017 end if; 13018 13019 Append_To (Stmts, 13020 Make_Implicit_If_Statement (N, 13021 Condition => New_Occurrence_Of (B, Loc), 13022 Then_Statements => E_Stats, 13023 Else_Statements => D_Stats)); 13024 end if; 13025 13026 Rewrite (N, 13027 Make_Block_Statement (Loc, 13028 Declarations => Decls, 13029 Handled_Statement_Sequence => 13030 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 13031 13032 Analyze (N); 13033 13034 -- Some items in Decls used to be in the N_Block in E_Call that is 13035 -- constructed in Expand_Entry_Call, and are now in the new Block 13036 -- into which N has been rewritten. Adjust their scopes to reflect that. 13037 13038 if Nkind (E_Call) = N_Block_Statement then 13039 Obj := First_Entity (Entity (Identifier (E_Call))); 13040 while Present (Obj) loop 13041 Set_Scope (Obj, Entity (Identifier (N))); 13042 Next_Entity (Obj); 13043 end loop; 13044 end if; 13045 13046 Reset_Scopes_To (N, Entity (Identifier (N))); 13047 end Expand_N_Timed_Entry_Call; 13048 13049 ---------------------------------------- 13050 -- Expand_Protected_Body_Declarations -- 13051 ---------------------------------------- 13052 13053 procedure Expand_Protected_Body_Declarations 13054 (N : Node_Id; 13055 Spec_Id : Entity_Id) 13056 is 13057 begin 13058 if No_Run_Time_Mode then 13059 Error_Msg_CRT ("protected body", N); 13060 return; 13061 13062 elsif Expander_Active then 13063 13064 -- Associate discriminals with the first subprogram or entry body to 13065 -- be expanded. 13066 13067 if Present (First_Protected_Operation (Declarations (N))) then 13068 Set_Discriminals (Parent (Spec_Id)); 13069 end if; 13070 end if; 13071 end Expand_Protected_Body_Declarations; 13072 13073 ------------------------- 13074 -- External_Subprogram -- 13075 ------------------------- 13076 13077 function External_Subprogram (E : Entity_Id) return Entity_Id is 13078 Subp : constant Entity_Id := Protected_Body_Subprogram (E); 13079 13080 begin 13081 -- The internal and external subprograms follow each other on the entity 13082 -- chain. Note that previously private operations had no separate 13083 -- external subprogram. We now create one in all cases, because a 13084 -- private operation may actually appear in an external call, through 13085 -- a 'Access reference used for a callback. 13086 13087 -- If the operation is a function that returns an anonymous access type, 13088 -- the corresponding itype appears before the operation, and must be 13089 -- skipped. 13090 13091 -- This mechanism is fragile, there should be a real link between the 13092 -- two versions of the operation, but there is no place to put it ??? 13093 13094 if Is_Access_Type (Next_Entity (Subp)) then 13095 return Next_Entity (Next_Entity (Subp)); 13096 else 13097 return Next_Entity (Subp); 13098 end if; 13099 end External_Subprogram; 13100 13101 ------------------------------ 13102 -- Extract_Dispatching_Call -- 13103 ------------------------------ 13104 13105 procedure Extract_Dispatching_Call 13106 (N : Node_Id; 13107 Call_Ent : out Entity_Id; 13108 Object : out Entity_Id; 13109 Actuals : out List_Id; 13110 Formals : out List_Id) 13111 is 13112 Call_Nam : Node_Id; 13113 13114 begin 13115 pragma Assert (Nkind (N) = N_Procedure_Call_Statement); 13116 13117 if Present (Original_Node (N)) then 13118 Call_Nam := Name (Original_Node (N)); 13119 else 13120 Call_Nam := Name (N); 13121 end if; 13122 13123 -- Retrieve the name of the dispatching procedure. It contains the 13124 -- dispatch table slot number. 13125 13126 loop 13127 case Nkind (Call_Nam) is 13128 when N_Identifier => 13129 exit; 13130 13131 when N_Selected_Component => 13132 Call_Nam := Selector_Name (Call_Nam); 13133 13134 when others => 13135 raise Program_Error; 13136 end case; 13137 end loop; 13138 13139 Actuals := Parameter_Associations (N); 13140 Call_Ent := Entity (Call_Nam); 13141 Formals := Parameter_Specifications (Parent (Call_Ent)); 13142 Object := First (Actuals); 13143 13144 if Present (Original_Node (Object)) then 13145 Object := Original_Node (Object); 13146 end if; 13147 13148 -- If the type of the dispatching object is an access type then return 13149 -- an explicit dereference of a copy of the object, and note that this 13150 -- is the controlling actual of the call. 13151 13152 if Is_Access_Type (Etype (Object)) then 13153 Object := 13154 Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object)); 13155 Analyze (Object); 13156 Set_Is_Controlling_Actual (Object); 13157 end if; 13158 end Extract_Dispatching_Call; 13159 13160 ------------------- 13161 -- Extract_Entry -- 13162 ------------------- 13163 13164 procedure Extract_Entry 13165 (N : Node_Id; 13166 Concval : out Node_Id; 13167 Ename : out Node_Id; 13168 Index : out Node_Id) 13169 is 13170 Nam : constant Node_Id := Name (N); 13171 13172 begin 13173 -- For a simple entry, the name is a selected component, with the 13174 -- prefix being the task value, and the selector being the entry. 13175 13176 if Nkind (Nam) = N_Selected_Component then 13177 Concval := Prefix (Nam); 13178 Ename := Selector_Name (Nam); 13179 Index := Empty; 13180 13181 -- For a member of an entry family, the name is an indexed component 13182 -- where the prefix is a selected component, whose prefix in turn is 13183 -- the task value, and whose selector is the entry family. The single 13184 -- expression in the expressions list of the indexed component is the 13185 -- subscript for the family. 13186 13187 else pragma Assert (Nkind (Nam) = N_Indexed_Component); 13188 Concval := Prefix (Prefix (Nam)); 13189 Ename := Selector_Name (Prefix (Nam)); 13190 Index := First (Expressions (Nam)); 13191 end if; 13192 13193 -- Through indirection, the type may actually be a limited view of a 13194 -- concurrent type. When compiling a call, the non-limited view of the 13195 -- type is visible. 13196 13197 if From_Limited_With (Etype (Concval)) then 13198 Set_Etype (Concval, Non_Limited_View (Etype (Concval))); 13199 end if; 13200 end Extract_Entry; 13201 13202 ------------------- 13203 -- Family_Offset -- 13204 ------------------- 13205 13206 function Family_Offset 13207 (Loc : Source_Ptr; 13208 Hi : Node_Id; 13209 Lo : Node_Id; 13210 Ttyp : Entity_Id; 13211 Cap : Boolean) return Node_Id 13212 is 13213 Ityp : Entity_Id; 13214 Real_Hi : Node_Id; 13215 Real_Lo : Node_Id; 13216 13217 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 13218 -- If one of the bounds is a reference to a discriminant, replace with 13219 -- corresponding discriminal of type. Within the body of a task retrieve 13220 -- the renamed discriminant by simple visibility, using its generated 13221 -- name. Within a protected object, find the original discriminant and 13222 -- replace it with the discriminal of the current protected operation. 13223 13224 ------------------------------ 13225 -- Convert_Discriminant_Ref -- 13226 ------------------------------ 13227 13228 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 13229 Loc : constant Source_Ptr := Sloc (Bound); 13230 B : Node_Id; 13231 D : Entity_Id; 13232 13233 begin 13234 if Is_Entity_Name (Bound) 13235 and then Ekind (Entity (Bound)) = E_Discriminant 13236 then 13237 if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then 13238 B := Make_Identifier (Loc, Chars (Entity (Bound))); 13239 Find_Direct_Name (B); 13240 13241 elsif Is_Protected_Type (Ttyp) then 13242 D := First_Discriminant (Ttyp); 13243 while Chars (D) /= Chars (Entity (Bound)) loop 13244 Next_Discriminant (D); 13245 end loop; 13246 13247 B := New_Occurrence_Of (Discriminal (D), Loc); 13248 13249 else 13250 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); 13251 end if; 13252 13253 elsif Nkind (Bound) = N_Attribute_Reference then 13254 return Bound; 13255 13256 else 13257 B := New_Copy_Tree (Bound); 13258 end if; 13259 13260 return 13261 Make_Attribute_Reference (Loc, 13262 Attribute_Name => Name_Pos, 13263 Prefix => New_Occurrence_Of (Etype (Bound), Loc), 13264 Expressions => New_List (B)); 13265 end Convert_Discriminant_Ref; 13266 13267 -- Start of processing for Family_Offset 13268 13269 begin 13270 Real_Hi := Convert_Discriminant_Ref (Hi); 13271 Real_Lo := Convert_Discriminant_Ref (Lo); 13272 13273 if Cap then 13274 if Is_Task_Type (Ttyp) then 13275 Ityp := RTE (RE_Task_Entry_Index); 13276 else 13277 Ityp := RTE (RE_Protected_Entry_Index); 13278 end if; 13279 13280 Real_Hi := 13281 Make_Attribute_Reference (Loc, 13282 Prefix => New_Occurrence_Of (Ityp, Loc), 13283 Attribute_Name => Name_Min, 13284 Expressions => New_List ( 13285 Real_Hi, 13286 Make_Integer_Literal (Loc, Entry_Family_Bound - 1))); 13287 13288 Real_Lo := 13289 Make_Attribute_Reference (Loc, 13290 Prefix => New_Occurrence_Of (Ityp, Loc), 13291 Attribute_Name => Name_Max, 13292 Expressions => New_List ( 13293 Real_Lo, 13294 Make_Integer_Literal (Loc, -Entry_Family_Bound))); 13295 end if; 13296 13297 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo); 13298 end Family_Offset; 13299 13300 ----------------- 13301 -- Family_Size -- 13302 ----------------- 13303 13304 function Family_Size 13305 (Loc : Source_Ptr; 13306 Hi : Node_Id; 13307 Lo : Node_Id; 13308 Ttyp : Entity_Id; 13309 Cap : Boolean) return Node_Id 13310 is 13311 Ityp : Entity_Id; 13312 13313 begin 13314 if Is_Task_Type (Ttyp) then 13315 Ityp := RTE (RE_Task_Entry_Index); 13316 else 13317 Ityp := RTE (RE_Protected_Entry_Index); 13318 end if; 13319 13320 return 13321 Make_Attribute_Reference (Loc, 13322 Prefix => New_Occurrence_Of (Ityp, Loc), 13323 Attribute_Name => Name_Max, 13324 Expressions => New_List ( 13325 Make_Op_Add (Loc, 13326 Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap), 13327 Right_Opnd => Make_Integer_Literal (Loc, 1)), 13328 Make_Integer_Literal (Loc, 0))); 13329 end Family_Size; 13330 13331 ---------------------------- 13332 -- Find_Enclosing_Context -- 13333 ---------------------------- 13334 13335 procedure Find_Enclosing_Context 13336 (N : Node_Id; 13337 Context : out Node_Id; 13338 Context_Id : out Entity_Id; 13339 Context_Decls : out List_Id) 13340 is 13341 begin 13342 -- Traverse the parent chain looking for an enclosing body, block, 13343 -- package or return statement. 13344 13345 Context := Parent (N); 13346 while Present (Context) loop 13347 if Nkind_In (Context, N_Entry_Body, 13348 N_Extended_Return_Statement, 13349 N_Package_Body, 13350 N_Package_Declaration, 13351 N_Subprogram_Body, 13352 N_Task_Body) 13353 then 13354 exit; 13355 13356 -- Do not consider block created to protect a list of statements with 13357 -- an Abort_Defer / Abort_Undefer_Direct pair. 13358 13359 elsif Nkind (Context) = N_Block_Statement 13360 and then not Is_Abort_Block (Context) 13361 then 13362 exit; 13363 end if; 13364 13365 Context := Parent (Context); 13366 end loop; 13367 13368 pragma Assert (Present (Context)); 13369 13370 -- Extract the constituents of the context 13371 13372 if Nkind (Context) = N_Extended_Return_Statement then 13373 Context_Decls := Return_Object_Declarations (Context); 13374 Context_Id := Return_Statement_Entity (Context); 13375 13376 -- Package declarations and bodies use a common library-level activation 13377 -- chain or task master, therefore return the package declaration as the 13378 -- proper carrier for the appropriate flag. 13379 13380 elsif Nkind (Context) = N_Package_Body then 13381 Context_Decls := Declarations (Context); 13382 Context_Id := Corresponding_Spec (Context); 13383 Context := Parent (Context_Id); 13384 13385 if Nkind (Context) = N_Defining_Program_Unit_Name then 13386 Context := Parent (Parent (Context)); 13387 else 13388 Context := Parent (Context); 13389 end if; 13390 13391 elsif Nkind (Context) = N_Package_Declaration then 13392 Context_Decls := Visible_Declarations (Specification (Context)); 13393 Context_Id := Defining_Unit_Name (Specification (Context)); 13394 13395 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13396 Context_Id := Defining_Identifier (Context_Id); 13397 end if; 13398 13399 else 13400 if Nkind (Context) = N_Block_Statement then 13401 Context_Id := Entity (Identifier (Context)); 13402 13403 elsif Nkind (Context) = N_Entry_Body then 13404 Context_Id := Defining_Identifier (Context); 13405 13406 elsif Nkind (Context) = N_Subprogram_Body then 13407 if Present (Corresponding_Spec (Context)) then 13408 Context_Id := Corresponding_Spec (Context); 13409 else 13410 Context_Id := Defining_Unit_Name (Specification (Context)); 13411 13412 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13413 Context_Id := Defining_Identifier (Context_Id); 13414 end if; 13415 end if; 13416 13417 elsif Nkind (Context) = N_Task_Body then 13418 Context_Id := Corresponding_Spec (Context); 13419 13420 else 13421 raise Program_Error; 13422 end if; 13423 13424 Context_Decls := Declarations (Context); 13425 end if; 13426 13427 pragma Assert (Present (Context_Id)); 13428 pragma Assert (Present (Context_Decls)); 13429 end Find_Enclosing_Context; 13430 13431 ----------------------- 13432 -- Find_Master_Scope -- 13433 ----------------------- 13434 13435 function Find_Master_Scope (E : Entity_Id) return Entity_Id is 13436 S : Entity_Id; 13437 13438 begin 13439 -- In Ada 2005, the master is the innermost enclosing scope that is not 13440 -- transient. If the enclosing block is the rewriting of a call or the 13441 -- scope is an extended return statement this is valid master. The 13442 -- master in an extended return is only used within the return, and is 13443 -- subsequently overwritten in Move_Activation_Chain, but it must exist 13444 -- now before that overwriting occurs. 13445 13446 S := Scope (E); 13447 13448 if Ada_Version >= Ada_2005 then 13449 while Is_Internal (S) loop 13450 if Nkind (Parent (S)) = N_Block_Statement 13451 and then 13452 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement 13453 then 13454 exit; 13455 13456 elsif Ekind (S) = E_Return_Statement then 13457 exit; 13458 13459 else 13460 S := Scope (S); 13461 end if; 13462 end loop; 13463 end if; 13464 13465 return S; 13466 end Find_Master_Scope; 13467 13468 ------------------------------- 13469 -- First_Protected_Operation -- 13470 ------------------------------- 13471 13472 function First_Protected_Operation (D : List_Id) return Node_Id is 13473 First_Op : Node_Id; 13474 13475 begin 13476 First_Op := First (D); 13477 while Present (First_Op) 13478 and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body) 13479 loop 13480 Next (First_Op); 13481 end loop; 13482 13483 return First_Op; 13484 end First_Protected_Operation; 13485 13486 --------------------------------------- 13487 -- Install_Private_Data_Declarations -- 13488 --------------------------------------- 13489 13490 procedure Install_Private_Data_Declarations 13491 (Loc : Source_Ptr; 13492 Spec_Id : Entity_Id; 13493 Conc_Typ : Entity_Id; 13494 Body_Nod : Node_Id; 13495 Decls : List_Id; 13496 Barrier : Boolean := False; 13497 Family : Boolean := False) 13498 is 13499 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ); 13500 Decl : Node_Id; 13501 Def : Node_Id; 13502 Insert_Node : Node_Id := Empty; 13503 Obj_Ent : Entity_Id; 13504 13505 procedure Add (Decl : Node_Id); 13506 -- Add a single declaration after Insert_Node. If this is the first 13507 -- addition, Decl is added to the front of Decls and it becomes the 13508 -- insertion node. 13509 13510 function Replace_Bound (Bound : Node_Id) return Node_Id; 13511 -- The bounds of an entry index may depend on discriminants, create a 13512 -- reference to the corresponding prival. Otherwise return a duplicate 13513 -- of the original bound. 13514 13515 --------- 13516 -- Add -- 13517 --------- 13518 13519 procedure Add (Decl : Node_Id) is 13520 begin 13521 if No (Insert_Node) then 13522 Prepend_To (Decls, Decl); 13523 else 13524 Insert_After (Insert_Node, Decl); 13525 end if; 13526 13527 Insert_Node := Decl; 13528 end Add; 13529 13530 ------------------- 13531 -- Replace_Bound -- 13532 ------------------- 13533 13534 function Replace_Bound (Bound : Node_Id) return Node_Id is 13535 begin 13536 if Nkind (Bound) = N_Identifier 13537 and then Is_Discriminal (Entity (Bound)) 13538 then 13539 return Make_Identifier (Loc, Chars (Entity (Bound))); 13540 else 13541 return Duplicate_Subexpr (Bound); 13542 end if; 13543 end Replace_Bound; 13544 13545 -- Start of processing for Install_Private_Data_Declarations 13546 13547 begin 13548 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote 13549 -- formal parameter _O, _object or _task depending on the context. 13550 13551 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ); 13552 13553 -- Special processing of _O for barrier functions, protected entries 13554 -- and families. 13555 13556 if Barrier 13557 or else 13558 (Is_Protected 13559 and then 13560 (Ekind (Spec_Id) = E_Entry 13561 or else Ekind (Spec_Id) = E_Entry_Family)) 13562 then 13563 declare 13564 Conc_Rec : constant Entity_Id := 13565 Corresponding_Record_Type (Conc_Typ); 13566 Typ_Id : constant Entity_Id := 13567 Make_Defining_Identifier (Loc, 13568 New_External_Name (Chars (Conc_Rec), 'P')); 13569 begin 13570 -- Generate: 13571 -- type prot_typVP is access prot_typV; 13572 13573 Decl := 13574 Make_Full_Type_Declaration (Loc, 13575 Defining_Identifier => Typ_Id, 13576 Type_Definition => 13577 Make_Access_To_Object_Definition (Loc, 13578 Subtype_Indication => 13579 New_Occurrence_Of (Conc_Rec, Loc))); 13580 Add (Decl); 13581 13582 -- Generate: 13583 -- _object : prot_typVP := prot_typV (_O); 13584 13585 Decl := 13586 Make_Object_Declaration (Loc, 13587 Defining_Identifier => 13588 Make_Defining_Identifier (Loc, Name_uObject), 13589 Object_Definition => New_Occurrence_Of (Typ_Id, Loc), 13590 Expression => 13591 Unchecked_Convert_To (Typ_Id, 13592 New_Occurrence_Of (Obj_Ent, Loc))); 13593 Add (Decl); 13594 13595 -- Set the reference to the concurrent object 13596 13597 Obj_Ent := Defining_Identifier (Decl); 13598 end; 13599 end if; 13600 13601 -- Step 2: Create the Protection object and build its declaration for 13602 -- any protected entry (family) of subprogram. Note for the lock-free 13603 -- implementation, the Protection object is not needed anymore. 13604 13605 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then 13606 declare 13607 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); 13608 Prot_Typ : RE_Id; 13609 13610 begin 13611 Set_Protection_Object (Spec_Id, Prot_Ent); 13612 13613 -- Determine the proper protection type 13614 13615 if Has_Attach_Handler (Conc_Typ) 13616 and then not Restricted_Profile 13617 then 13618 Prot_Typ := RE_Static_Interrupt_Protection; 13619 13620 elsif Has_Interrupt_Handler (Conc_Typ) 13621 and then not Restriction_Active (No_Dynamic_Attachment) 13622 then 13623 Prot_Typ := RE_Dynamic_Interrupt_Protection; 13624 13625 else 13626 case Corresponding_Runtime_Package (Conc_Typ) is 13627 when System_Tasking_Protected_Objects_Entries => 13628 Prot_Typ := RE_Protection_Entries; 13629 13630 when System_Tasking_Protected_Objects_Single_Entry => 13631 Prot_Typ := RE_Protection_Entry; 13632 13633 when System_Tasking_Protected_Objects => 13634 Prot_Typ := RE_Protection; 13635 13636 when others => 13637 raise Program_Error; 13638 end case; 13639 end if; 13640 13641 -- Generate: 13642 -- conc_typR : protection_typ renames _object._object; 13643 13644 Decl := 13645 Make_Object_Renaming_Declaration (Loc, 13646 Defining_Identifier => Prot_Ent, 13647 Subtype_Mark => 13648 New_Occurrence_Of (RTE (Prot_Typ), Loc), 13649 Name => 13650 Make_Selected_Component (Loc, 13651 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13652 Selector_Name => Make_Identifier (Loc, Name_uObject))); 13653 Add (Decl); 13654 end; 13655 end if; 13656 13657 -- Step 3: Add discriminant renamings (if any) 13658 13659 if Has_Discriminants (Conc_Typ) then 13660 declare 13661 D : Entity_Id; 13662 13663 begin 13664 D := First_Discriminant (Conc_Typ); 13665 while Present (D) loop 13666 13667 -- Adjust the source location 13668 13669 Set_Sloc (Discriminal (D), Loc); 13670 13671 -- Generate: 13672 -- discr_name : discr_typ renames _object.discr_name; 13673 -- or 13674 -- discr_name : discr_typ renames _task.discr_name; 13675 13676 Decl := 13677 Make_Object_Renaming_Declaration (Loc, 13678 Defining_Identifier => Discriminal (D), 13679 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc), 13680 Name => 13681 Make_Selected_Component (Loc, 13682 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13683 Selector_Name => Make_Identifier (Loc, Chars (D)))); 13684 Add (Decl); 13685 13686 -- Set debug info needed on this renaming declaration even 13687 -- though it does not come from source, so that the debugger 13688 -- will get the right information for these generated names. 13689 13690 Set_Debug_Info_Needed (Discriminal (D)); 13691 13692 Next_Discriminant (D); 13693 end loop; 13694 end; 13695 end if; 13696 13697 -- Step 4: Add private component renamings (if any) 13698 13699 if Is_Protected then 13700 Def := Protected_Definition (Parent (Conc_Typ)); 13701 13702 if Present (Private_Declarations (Def)) then 13703 declare 13704 Comp : Node_Id; 13705 Comp_Id : Entity_Id; 13706 Decl_Id : Entity_Id; 13707 13708 begin 13709 Comp := First (Private_Declarations (Def)); 13710 while Present (Comp) loop 13711 if Nkind (Comp) = N_Component_Declaration then 13712 Comp_Id := Defining_Identifier (Comp); 13713 Decl_Id := 13714 Make_Defining_Identifier (Loc, Chars (Comp_Id)); 13715 13716 -- Minimal decoration 13717 13718 if Ekind (Spec_Id) = E_Function then 13719 Set_Ekind (Decl_Id, E_Constant); 13720 else 13721 Set_Ekind (Decl_Id, E_Variable); 13722 end if; 13723 13724 Set_Prival (Comp_Id, Decl_Id); 13725 Set_Prival_Link (Decl_Id, Comp_Id); 13726 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); 13727 Set_Is_Independent (Decl_Id, Is_Independent (Comp_Id)); 13728 13729 -- Generate: 13730 -- comp_name : comp_typ renames _object.comp_name; 13731 13732 Decl := 13733 Make_Object_Renaming_Declaration (Loc, 13734 Defining_Identifier => Decl_Id, 13735 Subtype_Mark => 13736 New_Occurrence_Of (Etype (Comp_Id), Loc), 13737 Name => 13738 Make_Selected_Component (Loc, 13739 Prefix => 13740 New_Occurrence_Of (Obj_Ent, Loc), 13741 Selector_Name => 13742 Make_Identifier (Loc, Chars (Comp_Id)))); 13743 Add (Decl); 13744 end if; 13745 13746 Next (Comp); 13747 end loop; 13748 end; 13749 end if; 13750 end if; 13751 13752 -- Step 5: Add the declaration of the entry index and the associated 13753 -- type for barrier functions and entry families. 13754 13755 if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then 13756 declare 13757 E : constant Entity_Id := Index_Object (Spec_Id); 13758 Index : constant Entity_Id := 13759 Defining_Identifier 13760 (Entry_Index_Specification 13761 (Entry_Body_Formal_Part (Body_Nod))); 13762 Index_Con : constant Entity_Id := 13763 Make_Defining_Identifier (Loc, Chars (Index)); 13764 High : Node_Id; 13765 Index_Typ : Entity_Id; 13766 Low : Node_Id; 13767 13768 begin 13769 -- Minimal decoration 13770 13771 Set_Ekind (Index_Con, E_Constant); 13772 Set_Entry_Index_Constant (Index, Index_Con); 13773 Set_Discriminal_Link (Index_Con, Index); 13774 13775 -- Retrieve the bounds of the entry family 13776 13777 High := Type_High_Bound (Etype (Index)); 13778 Low := Type_Low_Bound (Etype (Index)); 13779 13780 -- In the simple case the entry family is given by a subtype mark 13781 -- and the index constant has the same type. 13782 13783 if Is_Entity_Name (Original_Node ( 13784 Discrete_Subtype_Definition (Parent (Index)))) 13785 then 13786 Index_Typ := Etype (Index); 13787 13788 -- Otherwise a new subtype declaration is required 13789 13790 else 13791 High := Replace_Bound (High); 13792 Low := Replace_Bound (Low); 13793 13794 Index_Typ := Make_Temporary (Loc, 'J'); 13795 13796 -- Generate: 13797 -- subtype Jnn is <Etype of Index> range Low .. High; 13798 13799 Decl := 13800 Make_Subtype_Declaration (Loc, 13801 Defining_Identifier => Index_Typ, 13802 Subtype_Indication => 13803 Make_Subtype_Indication (Loc, 13804 Subtype_Mark => 13805 New_Occurrence_Of (Base_Type (Etype (Index)), Loc), 13806 Constraint => 13807 Make_Range_Constraint (Loc, 13808 Range_Expression => 13809 Make_Range (Loc, Low, High)))); 13810 Add (Decl); 13811 end if; 13812 13813 Set_Etype (Index_Con, Index_Typ); 13814 13815 -- Create the object which designates the index: 13816 -- J : constant Jnn := 13817 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First)); 13818 -- 13819 -- where Jnn is the subtype created above or the original type of 13820 -- the index, _E is a formal of the protected body subprogram and 13821 -- <index expr> is the index of the first family member. 13822 13823 Decl := 13824 Make_Object_Declaration (Loc, 13825 Defining_Identifier => Index_Con, 13826 Constant_Present => True, 13827 Object_Definition => 13828 New_Occurrence_Of (Index_Typ, Loc), 13829 13830 Expression => 13831 Make_Attribute_Reference (Loc, 13832 Prefix => 13833 New_Occurrence_Of (Index_Typ, Loc), 13834 Attribute_Name => Name_Val, 13835 13836 Expressions => New_List ( 13837 13838 Make_Op_Add (Loc, 13839 Left_Opnd => 13840 Make_Op_Subtract (Loc, 13841 Left_Opnd => New_Occurrence_Of (E, Loc), 13842 Right_Opnd => 13843 Entry_Index_Expression (Loc, 13844 Defining_Identifier (Body_Nod), 13845 Empty, Conc_Typ)), 13846 13847 Right_Opnd => 13848 Make_Attribute_Reference (Loc, 13849 Prefix => 13850 New_Occurrence_Of (Index_Typ, Loc), 13851 Attribute_Name => Name_Pos, 13852 Expressions => New_List ( 13853 Make_Attribute_Reference (Loc, 13854 Prefix => 13855 New_Occurrence_Of (Index_Typ, Loc), 13856 Attribute_Name => Name_First))))))); 13857 Add (Decl); 13858 end; 13859 end if; 13860 end Install_Private_Data_Declarations; 13861 13862 --------------------------------- 13863 -- Is_Potentially_Large_Family -- 13864 --------------------------------- 13865 13866 function Is_Potentially_Large_Family 13867 (Base_Index : Entity_Id; 13868 Conctyp : Entity_Id; 13869 Lo : Node_Id; 13870 Hi : Node_Id) return Boolean 13871 is 13872 begin 13873 return Scope (Base_Index) = Standard_Standard 13874 and then Base_Index = Base_Type (Standard_Integer) 13875 and then Has_Discriminants (Conctyp) 13876 and then 13877 Present (Discriminant_Default_Value (First_Discriminant (Conctyp))) 13878 and then 13879 (Denotes_Discriminant (Lo, True) 13880 or else 13881 Denotes_Discriminant (Hi, True)); 13882 end Is_Potentially_Large_Family; 13883 13884 ------------------------------------- 13885 -- Is_Private_Primitive_Subprogram -- 13886 ------------------------------------- 13887 13888 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is 13889 begin 13890 return 13891 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure) 13892 and then Is_Private_Primitive (Id); 13893 end Is_Private_Primitive_Subprogram; 13894 13895 ------------------ 13896 -- Index_Object -- 13897 ------------------ 13898 13899 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is 13900 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id); 13901 Formal : Entity_Id; 13902 13903 begin 13904 Formal := First_Formal (Bod_Subp); 13905 while Present (Formal) loop 13906 13907 -- Look for formal parameter _E 13908 13909 if Chars (Formal) = Name_uE then 13910 return Formal; 13911 end if; 13912 13913 Next_Formal (Formal); 13914 end loop; 13915 13916 -- A protected body subprogram should always have the parameter in 13917 -- question. 13918 13919 raise Program_Error; 13920 end Index_Object; 13921 13922 -------------------------------- 13923 -- Make_Initialize_Protection -- 13924 -------------------------------- 13925 13926 function Make_Initialize_Protection 13927 (Protect_Rec : Entity_Id) return List_Id 13928 is 13929 Loc : constant Source_Ptr := Sloc (Protect_Rec); 13930 P_Arr : Entity_Id; 13931 Pdec : Node_Id; 13932 Ptyp : constant Node_Id := 13933 Corresponding_Concurrent_Type (Protect_Rec); 13934 Args : List_Id; 13935 L : constant List_Id := New_List; 13936 Has_Entry : constant Boolean := Has_Entries (Ptyp); 13937 Prio_Type : Entity_Id; 13938 Prio_Var : Entity_Id := Empty; 13939 Restricted : constant Boolean := Restricted_Profile; 13940 13941 begin 13942 -- We may need two calls to properly initialize the object, one to 13943 -- Initialize_Protection, and possibly one to Install_Handlers if we 13944 -- have a pragma Attach_Handler. 13945 13946 -- Get protected declaration. In the case of a task type declaration, 13947 -- this is simply the parent of the protected type entity. In the single 13948 -- protected object declaration, this parent will be the implicit type, 13949 -- and we can find the corresponding single protected object declaration 13950 -- by searching forward in the declaration list in the tree. 13951 13952 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes 13953 -- of this type should have been removed during semantic analysis. 13954 13955 Pdec := Parent (Ptyp); 13956 while not Nkind_In (Pdec, N_Protected_Type_Declaration, 13957 N_Single_Protected_Declaration) 13958 loop 13959 Next (Pdec); 13960 end loop; 13961 13962 -- Build the parameter list for the call. Note that _Init is the name 13963 -- of the formal for the object to be initialized, which is the task 13964 -- value record itself. 13965 13966 Args := New_List; 13967 13968 -- For lock-free implementation, skip initializations of the Protection 13969 -- object. 13970 13971 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 13972 13973 -- Object parameter. This is a pointer to the object of type 13974 -- Protection used by the GNARL to control the protected object. 13975 13976 Append_To (Args, 13977 Make_Attribute_Reference (Loc, 13978 Prefix => 13979 Make_Selected_Component (Loc, 13980 Prefix => Make_Identifier (Loc, Name_uInit), 13981 Selector_Name => Make_Identifier (Loc, Name_uObject)), 13982 Attribute_Name => Name_Unchecked_Access)); 13983 13984 -- Priority parameter. Set to Unspecified_Priority unless there is a 13985 -- Priority rep item, in which case we take the value from the pragma 13986 -- or attribute definition clause, or there is an Interrupt_Priority 13987 -- rep item and no Priority rep item, and we set the ceiling to 13988 -- Interrupt_Priority'Last, an implementation-defined value, see 13989 -- (RM D.3(10)). 13990 13991 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then 13992 declare 13993 Prio_Clause : constant Node_Id := 13994 Get_Rep_Item 13995 (Ptyp, Name_Priority, Check_Parents => False); 13996 13997 Prio : Node_Id; 13998 13999 begin 14000 -- Pragma Priority 14001 14002 if Nkind (Prio_Clause) = N_Pragma then 14003 Prio := 14004 Expression 14005 (First (Pragma_Argument_Associations (Prio_Clause))); 14006 14007 -- Get_Rep_Item returns either priority pragma 14008 14009 if Pragma_Name (Prio_Clause) = Name_Priority then 14010 Prio_Type := RTE (RE_Any_Priority); 14011 else 14012 Prio_Type := RTE (RE_Interrupt_Priority); 14013 end if; 14014 14015 -- Attribute definition clause Priority 14016 14017 else 14018 if Chars (Prio_Clause) = Name_Priority then 14019 Prio_Type := RTE (RE_Any_Priority); 14020 else 14021 Prio_Type := RTE (RE_Interrupt_Priority); 14022 end if; 14023 14024 Prio := Expression (Prio_Clause); 14025 end if; 14026 14027 -- Always create a locale variable to capture the priority. 14028 -- The priority is also passed to Install_Restriced_Handlers. 14029 -- Note that it is really necessary to create this variable 14030 -- explicitly. It might be thought that removing side effects 14031 -- would the appropriate approach, but that could generate 14032 -- declarations improperly placed in the enclosing scope. 14033 14034 Prio_Var := Make_Temporary (Loc, 'R', Prio); 14035 Append_To (L, 14036 Make_Object_Declaration (Loc, 14037 Defining_Identifier => Prio_Var, 14038 Object_Definition => New_Occurrence_Of (Prio_Type, Loc), 14039 Expression => Relocate_Node (Prio))); 14040 14041 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 14042 end; 14043 14044 -- When no priority is specified but an xx_Handler pragma is, we 14045 -- default to System.Interrupts.Default_Interrupt_Priority, see 14046 -- D.3(10). 14047 14048 elsif Has_Attach_Handler (Ptyp) 14049 or else Has_Interrupt_Handler (Ptyp) 14050 then 14051 Append_To (Args, 14052 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc)); 14053 14054 -- Normal case, no priority or xx_Handler specified, default priority 14055 14056 else 14057 Append_To (Args, 14058 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 14059 end if; 14060 14061 -- Deadline_Floor parameter for GNAT_Ravenscar_EDF runtimes 14062 14063 if Restricted_Profile and Task_Dispatching_Policy = 'E' then 14064 Deadline_Floor : declare 14065 Item : constant Node_Id := 14066 Get_Rep_Item 14067 (Ptyp, Name_Deadline_Floor, Check_Parents => False); 14068 14069 Deadline : Node_Id; 14070 14071 begin 14072 if Present (Item) then 14073 14074 -- Pragma Deadline_Floor 14075 14076 if Nkind (Item) = N_Pragma then 14077 Deadline := 14078 Expression 14079 (First (Pragma_Argument_Associations (Item))); 14080 14081 -- Attribute definition clause Deadline_Floor 14082 14083 else 14084 pragma Assert 14085 (Nkind (Item) = N_Attribute_Definition_Clause); 14086 14087 Deadline := Expression (Item); 14088 end if; 14089 14090 Append_To (Args, Deadline); 14091 14092 -- Unusual case: default deadline 14093 14094 else 14095 Append_To (Args, 14096 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 14097 end if; 14098 end Deadline_Floor; 14099 end if; 14100 14101 -- Test for Compiler_Info parameter. This parameter allows entry body 14102 -- procedures and barrier functions to be called from the runtime. It 14103 -- is a pointer to the record generated by the compiler to represent 14104 -- the protected object. 14105 14106 -- A protected type without entries that covers an interface and 14107 -- overrides the abstract routines with protected procedures is 14108 -- considered equivalent to a protected type with entries in the 14109 -- context of dispatching select statements. 14110 14111 -- Protected types with interrupt handlers (when not using a 14112 -- restricted profile) are also considered equivalent to protected 14113 -- types with entries. 14114 14115 -- The types which are used (Static_Interrupt_Protection and 14116 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries. 14117 14118 declare 14119 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); 14120 14121 Called_Subp : RE_Id; 14122 14123 begin 14124 case Pkg_Id is 14125 when System_Tasking_Protected_Objects_Entries => 14126 Called_Subp := RE_Initialize_Protection_Entries; 14127 14128 -- Argument Compiler_Info 14129 14130 Append_To (Args, 14131 Make_Attribute_Reference (Loc, 14132 Prefix => Make_Identifier (Loc, Name_uInit), 14133 Attribute_Name => Name_Address)); 14134 14135 when System_Tasking_Protected_Objects_Single_Entry => 14136 Called_Subp := RE_Initialize_Protection_Entry; 14137 14138 -- Argument Compiler_Info 14139 14140 Append_To (Args, 14141 Make_Attribute_Reference (Loc, 14142 Prefix => Make_Identifier (Loc, Name_uInit), 14143 Attribute_Name => Name_Address)); 14144 14145 when System_Tasking_Protected_Objects => 14146 Called_Subp := RE_Initialize_Protection; 14147 14148 when others => 14149 raise Program_Error; 14150 end case; 14151 14152 -- Entry_Queue_Maxes parameter. This is an access to an array of 14153 -- naturals representing the entry queue maximums for each entry 14154 -- in the protected type. Zero represents no max. The access is 14155 -- null if there is no limit for all entries (usual case). 14156 14157 if Has_Entry 14158 and then Pkg_Id = System_Tasking_Protected_Objects_Entries 14159 then 14160 if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then 14161 Append_To (Args, 14162 Make_Attribute_Reference (Loc, 14163 Prefix => 14164 New_Occurrence_Of 14165 (Entry_Max_Queue_Lengths_Array (Ptyp), Loc), 14166 Attribute_Name => Name_Unrestricted_Access)); 14167 else 14168 Append_To (Args, Make_Null (Loc)); 14169 end if; 14170 14171 -- Edge cases exist where entry initialization functions are 14172 -- called, but no entries exist, so null is appended. 14173 14174 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 14175 Append_To (Args, Make_Null (Loc)); 14176 end if; 14177 14178 -- Entry_Bodies parameter. This is a pointer to an array of 14179 -- pointers to the entry body procedures and barrier functions of 14180 -- the object. If the protected type has no entries this object 14181 -- will not exist, in this case, pass a null (it can happen when 14182 -- there are protected interrupt handlers or interfaces). 14183 14184 if Has_Entry then 14185 P_Arr := Entry_Bodies_Array (Ptyp); 14186 14187 -- Argument Entry_Body (for single entry) or Entry_Bodies (for 14188 -- multiple entries). 14189 14190 Append_To (Args, 14191 Make_Attribute_Reference (Loc, 14192 Prefix => New_Occurrence_Of (P_Arr, Loc), 14193 Attribute_Name => Name_Unrestricted_Access)); 14194 14195 if Pkg_Id = System_Tasking_Protected_Objects_Entries then 14196 14197 -- Find index mapping function (clumsy but ok for now) 14198 14199 while Ekind (P_Arr) /= E_Function loop 14200 Next_Entity (P_Arr); 14201 end loop; 14202 14203 Append_To (Args, 14204 Make_Attribute_Reference (Loc, 14205 Prefix => New_Occurrence_Of (P_Arr, Loc), 14206 Attribute_Name => Name_Unrestricted_Access)); 14207 end if; 14208 14209 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then 14210 14211 -- This is the case where we have a protected object with 14212 -- interfaces and no entries, and the single entry restriction 14213 -- is in effect. We pass a null pointer for the entry 14214 -- parameter because there is no actual entry. 14215 14216 Append_To (Args, Make_Null (Loc)); 14217 14218 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 14219 14220 -- This is the case where we have a protected object with no 14221 -- entries and: 14222 -- - either interrupt handlers with non restricted profile, 14223 -- - or interfaces 14224 -- Note that the types which are used for interrupt handlers 14225 -- (Static/Dynamic_Interrupt_Protection) are derived from 14226 -- Protection_Entries. We pass two null pointers because there 14227 -- is no actual entry, and the initialization procedure needs 14228 -- both Entry_Bodies and Find_Body_Index. 14229 14230 Append_To (Args, Make_Null (Loc)); 14231 Append_To (Args, Make_Null (Loc)); 14232 end if; 14233 14234 Append_To (L, 14235 Make_Procedure_Call_Statement (Loc, 14236 Name => 14237 New_Occurrence_Of (RTE (Called_Subp), Loc), 14238 Parameter_Associations => Args)); 14239 end; 14240 end if; 14241 14242 if Has_Attach_Handler (Ptyp) then 14243 14244 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to 14245 -- make the following call: 14246 14247 -- Install_Handlers (_object, 14248 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 14249 14250 -- or, in the case of Ravenscar: 14251 14252 -- Install_Restricted_Handlers 14253 -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access))); 14254 14255 declare 14256 Args : constant List_Id := New_List; 14257 Table : constant List_Id := New_List; 14258 Ritem : Node_Id := First_Rep_Item (Ptyp); 14259 14260 begin 14261 -- Build the Priority parameter (only for ravenscar) 14262 14263 if Restricted then 14264 14265 -- Priority comes from a pragma 14266 14267 if Present (Prio_Var) then 14268 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 14269 14270 -- Priority is the default one 14271 14272 else 14273 Append_To (Args, 14274 New_Occurrence_Of 14275 (RTE (RE_Default_Interrupt_Priority), Loc)); 14276 end if; 14277 end if; 14278 14279 -- Build the Attach_Handler table argument 14280 14281 while Present (Ritem) loop 14282 if Nkind (Ritem) = N_Pragma 14283 and then Pragma_Name (Ritem) = Name_Attach_Handler 14284 then 14285 declare 14286 Handler : constant Node_Id := 14287 First (Pragma_Argument_Associations (Ritem)); 14288 14289 Interrupt : constant Node_Id := Next (Handler); 14290 Expr : constant Node_Id := Expression (Interrupt); 14291 14292 begin 14293 Append_To (Table, 14294 Make_Aggregate (Loc, Expressions => New_List ( 14295 Unchecked_Convert_To 14296 (RTE (RE_System_Interrupt_Id), Expr), 14297 Make_Attribute_Reference (Loc, 14298 Prefix => 14299 Make_Selected_Component (Loc, 14300 Prefix => 14301 Make_Identifier (Loc, Name_uInit), 14302 Selector_Name => 14303 Duplicate_Subexpr_No_Checks 14304 (Expression (Handler))), 14305 Attribute_Name => Name_Access)))); 14306 end; 14307 end if; 14308 14309 Next_Rep_Item (Ritem); 14310 end loop; 14311 14312 -- Append the table argument we just built 14313 14314 Append_To (Args, Make_Aggregate (Loc, Table)); 14315 14316 -- Append the Install_Handlers (or Install_Restricted_Handlers) 14317 -- call to the statements. 14318 14319 if Restricted then 14320 -- Call a simplified version of Install_Handlers to be used 14321 -- when the Ravenscar restrictions are in effect 14322 -- (Install_Restricted_Handlers). 14323 14324 Append_To (L, 14325 Make_Procedure_Call_Statement (Loc, 14326 Name => 14327 New_Occurrence_Of 14328 (RTE (RE_Install_Restricted_Handlers), Loc), 14329 Parameter_Associations => Args)); 14330 14331 else 14332 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 14333 14334 -- First, prepends the _object argument 14335 14336 Prepend_To (Args, 14337 Make_Attribute_Reference (Loc, 14338 Prefix => 14339 Make_Selected_Component (Loc, 14340 Prefix => Make_Identifier (Loc, Name_uInit), 14341 Selector_Name => 14342 Make_Identifier (Loc, Name_uObject)), 14343 Attribute_Name => Name_Unchecked_Access)); 14344 end if; 14345 14346 -- Then, insert call to Install_Handlers 14347 14348 Append_To (L, 14349 Make_Procedure_Call_Statement (Loc, 14350 Name => 14351 New_Occurrence_Of (RTE (RE_Install_Handlers), Loc), 14352 Parameter_Associations => Args)); 14353 end if; 14354 end; 14355 end if; 14356 14357 return L; 14358 end Make_Initialize_Protection; 14359 14360 --------------------------- 14361 -- Make_Task_Create_Call -- 14362 --------------------------- 14363 14364 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is 14365 Loc : constant Source_Ptr := Sloc (Task_Rec); 14366 Args : List_Id; 14367 Ecount : Node_Id; 14368 Name : Node_Id; 14369 Tdec : Node_Id; 14370 Tdef : Node_Id; 14371 Tnam : Name_Id; 14372 Ttyp : Node_Id; 14373 14374 begin 14375 Ttyp := Corresponding_Concurrent_Type (Task_Rec); 14376 Tnam := Chars (Ttyp); 14377 14378 -- Get task declaration. In the case of a task type declaration, this is 14379 -- simply the parent of the task type entity. In the single task 14380 -- declaration, this parent will be the implicit type, and we can find 14381 -- the corresponding single task declaration by searching forward in the 14382 -- declaration list in the tree. 14383 14384 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of 14385 -- this type should have been removed during semantic analysis. 14386 14387 Tdec := Parent (Ttyp); 14388 while not Nkind_In (Tdec, N_Task_Type_Declaration, 14389 N_Single_Task_Declaration) 14390 loop 14391 Next (Tdec); 14392 end loop; 14393 14394 -- Now we can find the task definition from this declaration 14395 14396 Tdef := Task_Definition (Tdec); 14397 14398 -- Build the parameter list for the call. Note that _Init is the name 14399 -- of the formal for the object to be initialized, which is the task 14400 -- value record itself. 14401 14402 Args := New_List; 14403 14404 -- Priority parameter. Set to Unspecified_Priority unless there is a 14405 -- Priority rep item, in which case we take the value from the rep item. 14406 -- Not used on Ravenscar_EDF profile. 14407 14408 if not (Restricted_Profile and then Task_Dispatching_Policy = 'E') then 14409 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then 14410 Append_To (Args, 14411 Make_Selected_Component (Loc, 14412 Prefix => Make_Identifier (Loc, Name_uInit), 14413 Selector_Name => Make_Identifier (Loc, Name_uPriority))); 14414 else 14415 Append_To (Args, 14416 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 14417 end if; 14418 end if; 14419 14420 -- Optional Stack parameter 14421 14422 if Restricted_Profile then 14423 14424 -- If the stack has been preallocated by the expander then 14425 -- pass its address. Otherwise, pass a null address. 14426 14427 if Preallocated_Stacks_On_Target then 14428 Append_To (Args, 14429 Make_Attribute_Reference (Loc, 14430 Prefix => 14431 Make_Selected_Component (Loc, 14432 Prefix => Make_Identifier (Loc, Name_uInit), 14433 Selector_Name => Make_Identifier (Loc, Name_uStack)), 14434 Attribute_Name => Name_Address)); 14435 14436 else 14437 Append_To (Args, 14438 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 14439 end if; 14440 end if; 14441 14442 -- Size parameter. If no Storage_Size pragma is present, then 14443 -- the size is taken from the taskZ variable for the type, which 14444 -- is either Unspecified_Size, or has been reset by the use of 14445 -- a Storage_Size attribute definition clause. If a pragma is 14446 -- present, then the size is taken from the _Size field of the 14447 -- task value record, which was set from the pragma value. 14448 14449 if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then 14450 Append_To (Args, 14451 Make_Selected_Component (Loc, 14452 Prefix => Make_Identifier (Loc, Name_uInit), 14453 Selector_Name => Make_Identifier (Loc, Name_uSize))); 14454 14455 else 14456 Append_To (Args, 14457 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc)); 14458 end if; 14459 14460 -- Secondary_Stack parameter used for restricted profiles 14461 14462 if Restricted_Profile then 14463 14464 -- If the secondary stack has been allocated by the expander then 14465 -- pass its access pointer. Otherwise, pass null. 14466 14467 if Create_Secondary_Stack_For_Task (Ttyp) then 14468 Append_To (Args, 14469 Make_Attribute_Reference (Loc, 14470 Prefix => 14471 Make_Selected_Component (Loc, 14472 Prefix => Make_Identifier (Loc, Name_uInit), 14473 Selector_Name => 14474 Make_Identifier (Loc, Name_uSecondary_Stack)), 14475 Attribute_Name => Name_Unrestricted_Access)); 14476 14477 else 14478 Append_To (Args, Make_Null (Loc)); 14479 end if; 14480 end if; 14481 14482 -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there 14483 -- is a Secondary_Stack_Size pragma, in which case take the value from 14484 -- the pragma. If the restriction No_Secondary_Stack is active then a 14485 -- size of 0 is passed regardless to prevent the allocation of the 14486 -- unused stack. 14487 14488 if Restriction_Active (No_Secondary_Stack) then 14489 Append_To (Args, Make_Integer_Literal (Loc, 0)); 14490 14491 elsif Has_Rep_Pragma 14492 (Ttyp, Name_Secondary_Stack_Size, Check_Parents => False) 14493 then 14494 Append_To (Args, 14495 Make_Selected_Component (Loc, 14496 Prefix => Make_Identifier (Loc, Name_uInit), 14497 Selector_Name => 14498 Make_Identifier (Loc, Name_uSecondary_Stack_Size))); 14499 14500 else 14501 Append_To (Args, 14502 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 14503 end if; 14504 14505 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a 14506 -- Task_Info pragma, in which case we take the value from the pragma. 14507 14508 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then 14509 Append_To (Args, 14510 Make_Selected_Component (Loc, 14511 Prefix => Make_Identifier (Loc, Name_uInit), 14512 Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); 14513 14514 else 14515 Append_To (Args, 14516 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc)); 14517 end if; 14518 14519 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item, 14520 -- in which case we take the value from the rep item. The parameter is 14521 -- passed as an Integer because in the case of unspecified CPU the 14522 -- value is not in the range of CPU_Range. 14523 14524 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then 14525 Append_To (Args, 14526 Convert_To (Standard_Integer, 14527 Make_Selected_Component (Loc, 14528 Prefix => Make_Identifier (Loc, Name_uInit), 14529 Selector_Name => Make_Identifier (Loc, Name_uCPU)))); 14530 else 14531 Append_To (Args, 14532 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc)); 14533 end if; 14534 14535 if not Restricted_Profile or else Task_Dispatching_Policy = 'E' then 14536 14537 -- Deadline parameter. If no Relative_Deadline pragma is present, 14538 -- then the deadline is Time_Span_Zero. If a pragma is present, then 14539 -- the deadline is taken from the _Relative_Deadline field of the 14540 -- task value record, which was set from the pragma value. Note that 14541 -- this parameter must not be generated for the restricted profiles 14542 -- since Ravenscar does not allow deadlines. 14543 14544 -- Case where pragma Relative_Deadline applies: use given value 14545 14546 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then 14547 Append_To (Args, 14548 Make_Selected_Component (Loc, 14549 Prefix => Make_Identifier (Loc, Name_uInit), 14550 Selector_Name => 14551 Make_Identifier (Loc, Name_uRelative_Deadline))); 14552 14553 -- No pragma Relative_Deadline apply to the task 14554 14555 else 14556 Append_To (Args, 14557 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 14558 end if; 14559 end if; 14560 14561 if not Restricted_Profile then 14562 14563 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is 14564 -- present, then the dispatching domain is null. If a rep item is 14565 -- present, then the dispatching domain is taken from the 14566 -- _Dispatching_Domain field of the task value record, which was set 14567 -- from the rep item value. 14568 14569 -- Case where Dispatching_Domain rep item applies: use given value 14570 14571 if Has_Rep_Item 14572 (Ttyp, Name_Dispatching_Domain, Check_Parents => False) 14573 then 14574 Append_To (Args, 14575 Make_Selected_Component (Loc, 14576 Prefix => 14577 Make_Identifier (Loc, Name_uInit), 14578 Selector_Name => 14579 Make_Identifier (Loc, Name_uDispatching_Domain))); 14580 14581 -- No pragma or aspect Dispatching_Domain applies to the task 14582 14583 else 14584 Append_To (Args, Make_Null (Loc)); 14585 end if; 14586 14587 -- Number of entries. This is an expression of the form: 14588 14589 -- n + _Init.a'Length + _Init.a'B'Length + ... 14590 14591 -- where a,b... are the entry family names for the task definition 14592 14593 Ecount := 14594 Build_Entry_Count_Expression 14595 (Ttyp, 14596 Component_Items 14597 (Component_List 14598 (Type_Definition 14599 (Parent (Corresponding_Record_Type (Ttyp))))), 14600 Loc); 14601 Append_To (Args, Ecount); 14602 14603 -- Master parameter. This is a reference to the _Master parameter of 14604 -- the initialization procedure, except in the case of the pragma 14605 -- Restrictions (No_Task_Hierarchy) where the value is fixed to 14606 -- System.Tasking.Library_Task_Level. 14607 14608 if Restriction_Active (No_Task_Hierarchy) = False then 14609 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 14610 else 14611 Append_To (Args, 14612 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 14613 end if; 14614 end if; 14615 14616 -- State parameter. This is a pointer to the task body procedure. The 14617 -- required value is obtained by taking 'Unrestricted_Access of the task 14618 -- body procedure and converting it (with an unchecked conversion) to 14619 -- the type required by the task kernel. For further details, see the 14620 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather 14621 -- than 'Address in order to avoid creating trampolines. 14622 14623 declare 14624 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp); 14625 Subp_Ptr_Typ : constant Node_Id := 14626 Create_Itype (E_Access_Subprogram_Type, Tdec); 14627 Ref : constant Node_Id := Make_Itype_Reference (Loc); 14628 14629 begin 14630 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc); 14631 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); 14632 14633 -- Be sure to freeze a reference to the access-to-subprogram type, 14634 -- otherwise gigi will complain that it's in the wrong scope, because 14635 -- it's actually inside the init procedure for the record type that 14636 -- corresponds to the task type. 14637 14638 Set_Itype (Ref, Subp_Ptr_Typ); 14639 Append_Freeze_Action (Task_Rec, Ref); 14640 14641 Append_To (Args, 14642 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), 14643 Make_Qualified_Expression (Loc, 14644 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), 14645 Expression => 14646 Make_Attribute_Reference (Loc, 14647 Prefix => New_Occurrence_Of (Body_Proc, Loc), 14648 Attribute_Name => Name_Unrestricted_Access)))); 14649 end; 14650 14651 -- Discriminants parameter. This is just the address of the task 14652 -- value record itself (which contains the discriminant values 14653 14654 Append_To (Args, 14655 Make_Attribute_Reference (Loc, 14656 Prefix => Make_Identifier (Loc, Name_uInit), 14657 Attribute_Name => Name_Address)); 14658 14659 -- Elaborated parameter. This is an access to the elaboration Boolean 14660 14661 Append_To (Args, 14662 Make_Attribute_Reference (Loc, 14663 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')), 14664 Attribute_Name => Name_Unchecked_Access)); 14665 14666 -- Add Chain parameter (not done for sequential elaboration policy, see 14667 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 14668 14669 if Partition_Elaboration_Policy /= 'S' then 14670 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 14671 end if; 14672 14673 -- Task name parameter. Take this from the _Task_Id parameter to the 14674 -- init call unless there is a Task_Name pragma, in which case we take 14675 -- the value from the pragma. 14676 14677 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then 14678 -- Copy expression in full, because it may be dynamic and have 14679 -- side effects. 14680 14681 Append_To (Args, 14682 New_Copy_Tree 14683 (Expression 14684 (First 14685 (Pragma_Argument_Associations 14686 (Get_Rep_Pragma 14687 (Ttyp, Name_Task_Name, Check_Parents => False)))))); 14688 14689 else 14690 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); 14691 end if; 14692 14693 -- Created_Task parameter. This is the _Task_Id field of the task 14694 -- record value 14695 14696 Append_To (Args, 14697 Make_Selected_Component (Loc, 14698 Prefix => Make_Identifier (Loc, Name_uInit), 14699 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); 14700 14701 declare 14702 Create_RE : RE_Id; 14703 14704 begin 14705 if Restricted_Profile then 14706 if Partition_Elaboration_Policy = 'S' then 14707 Create_RE := RE_Create_Restricted_Task_Sequential; 14708 else 14709 Create_RE := RE_Create_Restricted_Task; 14710 end if; 14711 else 14712 Create_RE := RE_Create_Task; 14713 end if; 14714 14715 Name := New_Occurrence_Of (RTE (Create_RE), Loc); 14716 end; 14717 14718 return 14719 Make_Procedure_Call_Statement (Loc, 14720 Name => Name, 14721 Parameter_Associations => Args); 14722 end Make_Task_Create_Call; 14723 14724 ------------------------------ 14725 -- Next_Protected_Operation -- 14726 ------------------------------ 14727 14728 function Next_Protected_Operation (N : Node_Id) return Node_Id is 14729 Next_Op : Node_Id; 14730 14731 begin 14732 -- Check whether there is a subsequent body for a protected operation 14733 -- in the current protected body. In Ada2012 that includes expression 14734 -- functions that are completions. 14735 14736 Next_Op := Next (N); 14737 while Present (Next_Op) 14738 and then not Nkind_In (Next_Op, 14739 N_Subprogram_Body, N_Entry_Body, N_Expression_Function) 14740 loop 14741 Next (Next_Op); 14742 end loop; 14743 14744 return Next_Op; 14745 end Next_Protected_Operation; 14746 14747 --------------------- 14748 -- Null_Statements -- 14749 --------------------- 14750 14751 function Null_Statements (Stats : List_Id) return Boolean is 14752 Stmt : Node_Id; 14753 14754 begin 14755 Stmt := First (Stats); 14756 while Nkind (Stmt) /= N_Empty 14757 and then (Nkind_In (Stmt, N_Null_Statement, N_Label) 14758 or else 14759 (Nkind (Stmt) = N_Pragma 14760 and then 14761 Nam_In (Pragma_Name_Unmapped (Stmt), 14762 Name_Unreferenced, 14763 Name_Unmodified, 14764 Name_Warnings))) 14765 loop 14766 Next (Stmt); 14767 end loop; 14768 14769 return Nkind (Stmt) = N_Empty; 14770 end Null_Statements; 14771 14772 -------------------------- 14773 -- Parameter_Block_Pack -- 14774 -------------------------- 14775 14776 function Parameter_Block_Pack 14777 (Loc : Source_Ptr; 14778 Blk_Typ : Entity_Id; 14779 Actuals : List_Id; 14780 Formals : List_Id; 14781 Decls : List_Id; 14782 Stmts : List_Id) return Node_Id 14783 is 14784 Actual : Entity_Id; 14785 Expr : Node_Id := Empty; 14786 Formal : Entity_Id; 14787 Has_Param : Boolean := False; 14788 P : Entity_Id; 14789 Params : List_Id; 14790 Temp_Asn : Node_Id; 14791 Temp_Nam : Node_Id; 14792 14793 begin 14794 Actual := First (Actuals); 14795 Formal := Defining_Identifier (First (Formals)); 14796 Params := New_List; 14797 while Present (Actual) loop 14798 if Is_By_Copy_Type (Etype (Actual)) then 14799 -- Generate: 14800 -- Jnn : aliased <formal-type> 14801 14802 Temp_Nam := Make_Temporary (Loc, 'J'); 14803 14804 Append_To (Decls, 14805 Make_Object_Declaration (Loc, 14806 Aliased_Present => True, 14807 Defining_Identifier => Temp_Nam, 14808 Object_Definition => 14809 New_Occurrence_Of (Etype (Formal), Loc))); 14810 14811 -- The object is initialized with an explicit assignment 14812 -- later. Indicate that it does not need an initialization 14813 -- to prevent spurious warnings if the type excludes null. 14814 14815 Set_No_Initialization (Last (Decls)); 14816 14817 if Ekind (Formal) /= E_Out_Parameter then 14818 14819 -- Generate: 14820 -- Jnn := <actual> 14821 14822 Temp_Asn := 14823 New_Occurrence_Of (Temp_Nam, Loc); 14824 14825 Set_Assignment_OK (Temp_Asn); 14826 14827 Append_To (Stmts, 14828 Make_Assignment_Statement (Loc, 14829 Name => Temp_Asn, 14830 Expression => New_Copy_Tree (Actual))); 14831 end if; 14832 14833 -- If the actual is not controlling, generate: 14834 14835 -- Jnn'unchecked_access 14836 14837 -- and add it to aggegate for access to formals. Note that the 14838 -- actual may be by-copy but still be a controlling actual if it 14839 -- is an access to class-wide interface. 14840 14841 if not Is_Controlling_Actual (Actual) then 14842 Append_To (Params, 14843 Make_Attribute_Reference (Loc, 14844 Attribute_Name => Name_Unchecked_Access, 14845 Prefix => New_Occurrence_Of (Temp_Nam, Loc))); 14846 14847 Has_Param := True; 14848 end if; 14849 14850 -- The controlling parameter is omitted 14851 14852 else 14853 if not Is_Controlling_Actual (Actual) then 14854 Append_To (Params, 14855 Make_Reference (Loc, New_Copy_Tree (Actual))); 14856 14857 Has_Param := True; 14858 end if; 14859 end if; 14860 14861 Next_Actual (Actual); 14862 Next_Formal_With_Extras (Formal); 14863 end loop; 14864 14865 if Has_Param then 14866 Expr := Make_Aggregate (Loc, Params); 14867 end if; 14868 14869 -- Generate: 14870 -- P : Ann := ( 14871 -- J1'unchecked_access; 14872 -- <actual2>'reference; 14873 -- ...); 14874 14875 P := Make_Temporary (Loc, 'P'); 14876 14877 Append_To (Decls, 14878 Make_Object_Declaration (Loc, 14879 Defining_Identifier => P, 14880 Object_Definition => New_Occurrence_Of (Blk_Typ, Loc), 14881 Expression => Expr)); 14882 14883 return P; 14884 end Parameter_Block_Pack; 14885 14886 ---------------------------- 14887 -- Parameter_Block_Unpack -- 14888 ---------------------------- 14889 14890 function Parameter_Block_Unpack 14891 (Loc : Source_Ptr; 14892 P : Entity_Id; 14893 Actuals : List_Id; 14894 Formals : List_Id) return List_Id 14895 is 14896 Actual : Entity_Id; 14897 Asnmt : Node_Id; 14898 Formal : Entity_Id; 14899 Has_Asnmt : Boolean := False; 14900 Result : constant List_Id := New_List; 14901 14902 begin 14903 Actual := First (Actuals); 14904 Formal := Defining_Identifier (First (Formals)); 14905 while Present (Actual) loop 14906 if Is_By_Copy_Type (Etype (Actual)) 14907 and then Ekind (Formal) /= E_In_Parameter 14908 then 14909 -- Generate: 14910 -- <actual> := P.<formal>; 14911 14912 Asnmt := 14913 Make_Assignment_Statement (Loc, 14914 Name => 14915 New_Copy (Actual), 14916 Expression => 14917 Make_Explicit_Dereference (Loc, 14918 Make_Selected_Component (Loc, 14919 Prefix => 14920 New_Occurrence_Of (P, Loc), 14921 Selector_Name => 14922 Make_Identifier (Loc, Chars (Formal))))); 14923 14924 Set_Assignment_OK (Name (Asnmt)); 14925 Append_To (Result, Asnmt); 14926 14927 Has_Asnmt := True; 14928 end if; 14929 14930 Next_Actual (Actual); 14931 Next_Formal_With_Extras (Formal); 14932 end loop; 14933 14934 if Has_Asnmt then 14935 return Result; 14936 else 14937 return New_List (Make_Null_Statement (Loc)); 14938 end if; 14939 end Parameter_Block_Unpack; 14940 14941 --------------------- 14942 -- Reset_Scopes_To -- 14943 --------------------- 14944 14945 procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is 14946 function Reset_Scope (N : Node_Id) return Traverse_Result; 14947 -- Temporaries may have been declared during expansion of the procedure 14948 -- created for an entry body or an accept alternative. Indicate that 14949 -- their scope is the new body, to ensure proper generation of uplevel 14950 -- references where needed during unnesting. 14951 14952 procedure Reset_Scopes is new Traverse_Proc (Reset_Scope); 14953 14954 ----------------- 14955 -- Reset_Scope -- 14956 ----------------- 14957 14958 function Reset_Scope (N : Node_Id) return Traverse_Result is 14959 Decl : Node_Id; 14960 14961 begin 14962 -- If this is a block statement with an Identifier, it forms a scope, 14963 -- so we want to reset its scope but not look inside. 14964 14965 if N /= Bod 14966 and then Nkind (N) = N_Block_Statement 14967 and then Present (Identifier (N)) 14968 then 14969 Set_Scope (Entity (Identifier (N)), E); 14970 return Skip; 14971 14972 -- Ditto for a package declaration or a full type declaration, etc. 14973 14974 elsif (Nkind (N) = N_Package_Declaration 14975 and then N /= Specification (N)) 14976 or else Nkind (N) in N_Declaration 14977 or else Nkind (N) in N_Renaming_Declaration 14978 then 14979 Set_Scope (Defining_Entity (N), E); 14980 return Skip; 14981 14982 elsif N = Bod then 14983 14984 -- Scan declarations in new body. Declarations in the statement 14985 -- part will be handled during later traversal. 14986 14987 Decl := First (Declarations (N)); 14988 while Present (Decl) loop 14989 Reset_Scopes (Decl); 14990 Next (Decl); 14991 end loop; 14992 14993 elsif Nkind (N) = N_Freeze_Entity then 14994 14995 -- Scan the actions associated with a freeze node, which may 14996 -- actually be declarations with entities that need to have 14997 -- their scopes reset. 14998 14999 Decl := First (Actions (N)); 15000 while Present (Decl) loop 15001 Reset_Scopes (Decl); 15002 Next (Decl); 15003 end loop; 15004 15005 elsif N /= Bod and then Nkind (N) in N_Proper_Body then 15006 15007 -- A subprogram without a separate declaration may be encountered, 15008 -- and we need to reset the subprogram's entity's scope. 15009 15010 if Nkind (N) = N_Subprogram_Body then 15011 Set_Scope (Defining_Entity (Specification (N)), E); 15012 end if; 15013 15014 return Skip; 15015 end if; 15016 15017 return OK; 15018 end Reset_Scope; 15019 15020 -- Start of processing for Reset_Scopes_To 15021 15022 begin 15023 Reset_Scopes (Bod); 15024 end Reset_Scopes_To; 15025 15026 ---------------------- 15027 -- Set_Discriminals -- 15028 ---------------------- 15029 15030 procedure Set_Discriminals (Dec : Node_Id) is 15031 D : Entity_Id; 15032 Pdef : Entity_Id; 15033 D_Minal : Entity_Id; 15034 15035 begin 15036 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); 15037 Pdef := Defining_Identifier (Dec); 15038 15039 if Has_Discriminants (Pdef) then 15040 D := First_Discriminant (Pdef); 15041 while Present (D) loop 15042 D_Minal := 15043 Make_Defining_Identifier (Sloc (D), 15044 Chars => New_External_Name (Chars (D), 'D')); 15045 15046 Set_Ekind (D_Minal, E_Constant); 15047 Set_Etype (D_Minal, Etype (D)); 15048 Set_Scope (D_Minal, Pdef); 15049 Set_Discriminal (D, D_Minal); 15050 Set_Discriminal_Link (D_Minal, D); 15051 15052 Next_Discriminant (D); 15053 end loop; 15054 end if; 15055 end Set_Discriminals; 15056 15057 ----------------------- 15058 -- Trivial_Accept_OK -- 15059 ----------------------- 15060 15061 function Trivial_Accept_OK return Boolean is 15062 begin 15063 case Opt.Task_Dispatching_Policy is 15064 15065 -- If we have the default task dispatching policy in effect, we can 15066 -- definitely do the optimization (one way of looking at this is to 15067 -- think of the formal definition of the default policy being allowed 15068 -- to run any task it likes after a rendezvous, so even if notionally 15069 -- a full rescheduling occurs, we can say that our dispatching policy 15070 -- (i.e. the default dispatching policy) reorders the queue to be the 15071 -- same as just before the call. 15072 15073 when ' ' => 15074 return True; 15075 15076 -- FIFO_Within_Priorities certainly does not permit this 15077 -- optimization since the Rendezvous is a scheduling action that may 15078 -- require some other task to be run. 15079 15080 when 'F' => 15081 return False; 15082 15083 -- For now, disallow the optimization for all other policies. This 15084 -- may be over-conservative, but it is certainly not incorrect. 15085 15086 when others => 15087 return False; 15088 end case; 15089 end Trivial_Accept_OK; 15090 15091end Exp_Ch9; 15092